ラベル Delphi 2007 の投稿を表示しています。 すべての投稿を表示
ラベル Delphi 2007 の投稿を表示しています。 すべての投稿を表示

2016年2月26日

Windowsがサーバ版かどうかを調べる

プログラムが動作している環境(Windows)がサーバ版かどうかを調べたいことがまれにあります(WMIでサーバ版Windowsではサポートされていない項目の問い合わせをするときなど)。RTLのソースをちょっと覗いてみたところ、Win32APIのGetVersionEx (ja)関数で取得したOSVERSIONINFOEX構造体のwProductTypeがVER_NT_WORKSTATIONかどうかで判断できるようなのですが、GetVersionEx関数のRemarksにはVerifyVersionInfo (ja)関数を使ったほうがパフォーマンス上望ましい、と書いてあるようなので、VerifyVersionInfo関数(とそのパラメータを組み立てるためにVerSetConditionMask関数の組み合わせ)で実現してみました。
function IsWindowsServer: Boolean;
var
  OSVI: TOSVersionInfoEx;
  ConditionMask: UInt64;
begin

  FillChar(OSVI,SizeOf(TOSVersionInfoEX),0);
  OSVI.dwOSVersionInfoSize := SizeOf(OSVI);
  OSVI.wProductType := VER_NT_WORKSTATION;

  ConditionMask := VerSetConditionMask(0,VER_PRODUCT_TYPE,VER_EQUAL);

  Result := not (VerifyVersionInfo(OSVI,VER_PRODUCT_TYPE,ConditionMask));

end;
OSVERSIONINFOEX構造体を初期化後、wProductTypeにVER_NT_WORKSTATIONを格納し、これに対応する条件マスク(VER_PRODUCT_TYPEがVER_EQUAL)をVerifyVersionInfoで作成してVerifyVersionInfoで問い合わせて、結果がFalse(wProductTypeがVER_NT_WORKSTATION以外)ならサーバ版Windows、という判定です。

→Windowsがサーバ版かどうかを調べる(Gist)

2016年2月5日

整数の中で立っているビットの数を数える

それほど機会が多いわけではありませんが、整数の中で立っているビットの数を数えたいということがあります。C++であればstd::bitsetのcountを使えば一発ですが、残念ながらDelphiでは符号なし整数型のヘルパ(TByteHelper/TWordHelper/TCardinalHelper/TUInt64Helper)を含め、標準ではそのような機能がありません。でちょっと検索してみたところ、population countあるいはHamming weightというキーワードが浮かんできました。最近のCPUには専用の命令(x86だとSSE4.2以降のPOPCNT)がありますが、移植性などを考慮して、Delphiで実装してみました。とはいってもCで書かれたものをそのままDelphiに置き換えただけです。詳細や原理については○×つくろーどっとコムさんのその17 ビット演算あれこれや中村実さんのビットを数える・探すアルゴリズムなどを、またx86/x64のPOPCNT命令との比較についてはtakesakoさんのx86x64 SSE4.2 POPCNTあたりを参照してください。
function PopulationCount(Value: UInt8): Integer;
begin

  Value := (Value and $55) + ((Value shr 1) and $55);
  Value := (Value and $33) + ((Value shr 2) and $33);
  Value := (Value and $0F) + ((Value shr 4) and $0F);
  Result := Value;

end;

function PopulationCount(Value: UInt16): Integer;
begin

  Value := (Value and $5555) + ((Value shr 1) and $5555);
  Value := (Value and $3333) + ((Value shr 2) and $3333);
  Value := (Value and $0F0F) + ((Value shr 4) and $0F0F);
  Value := (Value and $00FF) + ((Value shr 8) and $00FF);
  Result := Value;

end;

function PopulationCount(Value: UInt32): Integer;
begin

  Value := (Value and $55555555) + ((Value shr  1) and $55555555);
  Value := (Value and $33333333) + ((Value shr  2) and $33333333);
  Value := (Value and $0F0F0F0F) + ((Value shr  4) and $0F0F0F0F);
  Value := (Value and $00FF00FF) + ((Value shr  8) and $00FF00FF);
  Value := (Value and $0000FFFF) + ((Value shr 16) and $0000FFFF);
  Result := Value;

end;

function PopulationCount(Value: UInt64): Integer;
begin

  Value := (Value and $5555555555555555) + ((Value shr  1) and $5555555555555555);
  Value := (Value and $3333333333333333) + ((Value shr  2) and $3333333333333333);
  Value := (Value and $0F0F0F0F0F0F0F0F) + ((Value shr  4) and $0F0F0F0F0F0F0F0F);
  Value := (Value and $00FF00FF00FF00FF) + ((Value shr  8) and $00FF00FF00FF00FF);
  Value := (Value and $0000FFFF0000FFFF) + ((Value shr 16) and $0000FFFF0000FFFF);
  Value := (Value and $00000000FFFFFFFF) + ((Value shr 32) and $00000000FFFFFFFF);
  Result := Value;

end;
→整数の中で立っているビットの数を数える(Gist)

2020/06/01追記: Delphi 10.4 Sydneyでは標準関数(かつ組み込みルーチン(en))としてCountLeadingZeros32(先頭の(MSBからの)連続している0の数/32bit整数)、CountLeadingZeros64(先頭の(MSBからの)連続している0の数/64bit整数)、CountTrailingZeros32(末尾のの(LSBからの)連続している0の数/32bit整数)、CountTrailingZeros64(末尾のの(LSBからの)連続している0の数/64bit整数)、CountPopulation32(1になっているビットの数/32bit整数)、CountPopulation64(1になっているビットの数/64bit整数)が追加されました。これらの関数はコンパイラによってインラインで展開されるため、System.pasなどに定義がありません。またこれらの関数は現時点ではヘルプ上に記述がありません。

2015年8月5日

IDE Fix Pack 4.4 for Delphi 2007 Windows 10 Edition

Andreas HausladenさんのIDE Fix Pack for Delphi 2007のWindows 10対応版がリリースされています。Windows 7およびそれ以前では4.4を、Windows 8/8.1では4.3を、Windows 10では4.4 Windows 10 Editionを、というようにWindowsのバージョンによって対応が分かれているので注意が必要です。

IDE Fix Pack 4.4 for Delphi 2007 – Windows 10 Edition | Andy's Blog and Tools

2015年1月6日

シリアルポートをフレンドリ名で列挙する

以前使用できるシリアルポートをレジストリから列挙する方法について書きましたが、今度はシリアルポートをそのフレンドリ名(デバイスマネージャ上で表示される表記)とともに列挙する方法です。

フレンドリ名の取得にはSetup APIを使用しますが、残念ながらDelphiにはSetup API関係の定義が含まれていない(C++Builderならsetupapi.hがあるのですが)ため、まずは必要なWin32APIと構造体を定義します。
{ Setup APIs }
type
  { HDEVINFO }
  HDEVINFO = THandle;
  {$EXTERNALSYM HDEVINFO}

  { SP_DEVINFO_DATA }
  SP_DEVINFO_DATA = packed record
    cbSize: DWORD;
    ClassGuid: TGUID;
    DevInst: DWORD;
    Reserved: ULONG_PTR;
  end;
  {$EXTERNALSYM SP_DEVINFO_DATA}

const
  { Flags for SetupDiGetClassDevs }
  DIGCF_PRESENT         = $00000002;
  {$EXTERNALSYM DIGCF_PRESENT}

  { Property for SetupDiGetDeviceRegistryProperty }
  SPDRP_DEVICEDESC      = $00000000;
  {$EXTERNALSYM SPDRP_DEVICEDESC}
  SPDRP_FRIENDLYNAME    = $0000000C;
  {$EXTERNALSYM SPDRP_FRIENDLYNAME}

  { Scope for SetupDiOpenDevRegKey }
  DICS_FLAG_GLOBAL      = $00000001;
  {$EXTERNALSYM DICS_FLAG_GLOBAL}

  { KeyType for SetupDiOpenDevRegKey }
  DIREG_DEV             = $00000001;
  {$EXTERNALSYM DIREG_DEV}

{ SetupDiClassGuidsFromName }
function SetupDiClassGuidsFromName(const ClassName: PChar;
                                   ClassGuidList: PGUID;
                                   ClassGuidListSize: DWORD;
                                   var RequiredSize: DWORD): BOOL; stdcall;
  external 'SetupApi.dll' name
{$IFDEF UNICODE}
  'SetupDiClassGuidsFromNameW';
{$ELSE}
  'SetupDiClassGuidsFromNameA';
{$ENDIF}
{$EXTERNALSYM SetupDiClassGuidsFromName}

{ SetupDiGetClassDevs }
function SetupDiGetClassDevs(ClassGuid: PGUID;
                             const Enumerator: PChar;
                             hwndParent: HWND;
                             Flags: DWORD): HDEVINFO; stdcall;
  external 'SetupApi.dll' name
{$IFDEF UNICODE}
  'SetupDiGetClassDevsW';
{$ELSE}
  'SetupDiGetClassDevsA';
{$ENDIF}
{$EXTERNALSYM SetupDiGetClassDevs}

{ SetupDiDestroyDeviceInfoList }
function SetupDiDestroyDeviceInfoList(DeviceInfoSet: HDEVINFO): BOOL; stdcall;
  external 'SetupApi.dll' name 'SetupDiDestroyDeviceInfoList';
{$EXTERNALSYM SetupDiDestroyDeviceInfoList}

{ SetupDiEnumDeviceInfo }
function SetupDiEnumDeviceInfo(DeviceInfoSet: HDEVINFO;
                               MemberIndex: DWORD;
                               var DeviceInfoData: SP_DEVINFO_DATA): BOOL; stdcall;
  external 'SetupApi.dll' name 'SetupDiEnumDeviceInfo';
{$EXTERNALSYM SetupDiEnumDeviceInfo}

{ SetupDiGetDeviceRegistryProperty }
function SetupDiGetDeviceRegistryProperty(DeviceInfoSet: HDEVINFO;
                                          const DeviceInfoData: SP_DEVINFO_DATA;
                                          Prop: DWORD;
                                          PropertyRegDataType: PDWORD;
                                          PropertyBuffer: Pointer;
                                          PropertyBufferSize: DWORD;
                                          var RequiredSize: DWORD): BOOL; stdcall;
  external 'SetupApi.dll' name
{$IFDEF UNICODE}
  'SetupDiGetDeviceRegistryPropertyW';
{$ELSE}
  'SetupDiGetDeviceRegistryPropertyA';
{$ENDIF}
{$EXTERNALSYM SetupDiGetDeviceRegistryProperty}

{ SetupDiOpenDevRegKey }
function SetupDiOpenDevRegKey(DeviceInfoSet: HDEVINFO;
                              var DeviceInfoData: SP_DEVINFO_DATA;
                              Scope: DWORD;
                              HwProfile: DWORD;
                              KeyType: DWORD;
                              samDesired: REGSAM): HKEY; stdcall;
  external 'SetupApi.dll' name 'SetupDiOpenDevRegKey';
{$EXTERNALSYM SetupDiOpenDevRegKey}
これらを使用してシリアルポートをそのフレンドリ名とともに取得します。
function EnumSerialCommWithFriendlyName(const S: TStrings): Integer;
var
  Guid: TGUID;
  Size: DWORD;
  hDevInf: HDEVINFO;
  Index: DWORD;
  DevInfoData: SP_DEVINFO_DATA;
  S1: String;
  hRegKey: HKEY;
  S2: String;
  RegType: DWORD;
  PortNo: Integer;
begin

  Result := 0;

  Size := 0;
  if SetupDiClassGuidsFromName('Ports',@Guid,1,Size) = False then
  begin
    RaiseLastOSError;
  end;

  hDevInf := SetupDiGetClassDevs(@Guid,nil,0,DIGCF_PRESENT);
  if hDevInf = INVALID_HANDLE_VALUE then
  begin
    RaiseLastOSError;
  end;

  try
    Index := 0;
    while True do
    begin
      FillChar(DevInfoData,SizeOf(DevInfoData),0);
      DevInfoData.cbSize := SizeOf(DevInfoData);
      if SetupDiEnumDeviceInfo(hDevInf,Index,DevInfoData) = False then
      begin
        Break;
      end;

      SetupDiGetDeviceRegistryProperty(hDevInf,DevInfoData,SPDRP_FRIENDLYNAME,
                                       nil,nil,0,Size);
      SetLength(S1,(Size + SizeOf(Char)) div SizeOf(Char));

      if SetupDiGetDeviceRegistryProperty(hDevInf,DevInfoData,SPDRP_FRIENDLYNAME,
                                          nil,PChar(S1),Size,Size) = True then
      begin
        SetLength(S1,StrLen(PChar(S1)));
        hRegKey := SetupDiOpenDevRegKey(hDevInf,DevInfoData,DICS_FLAG_GLOBAL,0,DIREG_DEV,KEY_READ);
        if hRegKey <> INVALID_HANDLE_VALUE then
        begin
          try
            if RegQueryInfoKey(hRegKey,nil,nil,nil,nil,nil,nil,nil,nil,
                               @Size,nil,nil) = ERROR_SUCCESS then
            begin
              SetLength(S2,(Size + SizeOf(Char)) div SizeOf(Char));
              if (RegQueryValueEx(hRegKey,'PortName',nil,@RegType,Pointer(PChar(S2)),
                                  @Size) = ERROR_SUCCESS) and
                 (RegType = REG_SZ) then
              begin
                SetLength(S2,StrLen(PChar(S2)));
                if CompareText(Copy(S2,1,3),'COM') = 0 then
                begin
                  if TryStrToInt(Copy(S2,4,Length(S2)),PortNo) = True then
                  begin
                    S.AddObject(S1,Pointer(PortNo));
                    if Result < PortNo then
                    begin
                      Result := PortNo;
                    end;
                  end;
                end;
              end;
            end;

          finally
            RegCloseKey(hRegKey);
          end;
        end;
      end;

      Index := Index + 1;
    end;

  finally
    SetupDiDestroyDeviceInfoList(hDevInf);
  end;

end;
手順ですが、まずSetupDiClassGuidsFromNameでデバイスインタフェースクラスが'Ports'のGUIDを取得し、そのGUIDを使用してSetupDiGetClassDevsで現在システムに認識されているDevice Information Setsを取得し、SetupDiEnumDeviceInfoでDevice Information Set一つずつの情報をSP_DEVINFO_DATAに取り出して、SetupDiGetDeviceRegistryPropertyでフレンドリ名を取得します。さらにSetupDiOpenDevRegKeyでデバイス固有情報の含まれるレジストリキー('HKEY_LOCAL_MACHINE\SYSTEM\CurrentControlSet\Enum'の下のデバイスごとのキーに含まれる'Device Parameters'キー)を開き、RegQueryValueExで'PortName'という名前でREG_SZの値のデータを文字列として取得し、'COM'で始まっていたらシリアルポートとしてフレンドリ名とともにパラメータ(S: TStrings)に格納します。全てのDevice Information Setをチェックし終わったらSetupDiDestroyDeviceInfoListでDevice Information Sets全体を解放します。 以前のものと同様に必ずしもポート番号順にはなっていないため、必要に応じて結果をソートしてください。

→シリアルポートをフレンドリ名で列挙 (Gist)

2013年8月22日

Win32APIのSetPriorityClass関数でプロセスの優先順位を指定する

実行中のプロセスの優先順位クラス (Priority class)を取得/設定するにはWin32APIのGetPriorityClass関数 (en)およびSetPriorityClass関数 (en)を使用します。このとき自プロセスの優先順位クラスを指定するのであればGetCurrentProcess関数 (en)で取得した擬似ハンドルを使用することができます(他のプロセスの優先順位クラスの場合、PROCESS_SET_INFORMATIONアクセス権を持ったプロセスハンドルが必要です)。

まずBELOW_NORMAL_PRIORITY_CLASSとABOVE_NORMAL_PRIORITY_CLASSの定義を追加します。
{$IF RTLVersion < 24}
const
  BELOW_NORMAL_PRIORITY_CLASS = $00004000;
  {$EXTERNALSYM ABOVE_NORMAL_PRIORITY_CLASS}
  ABOVE_NORMAL_PRIORITY_CLASS = $00008000;
  {$EXTERNALSYM ABOVE_NORMAL_PRIORITY_CLASS}
{$IFEND}
フォームに優先順位クラスを表示するComboBox(StyleはcsDropDownList)と優先順位クラスを取得、設定するButtonを配置し、フォームのOnCreateイベントでComboBoxに優先順位クラスの表示文字列と値を格納します。
procedure TForm1.FormCreate(Sender: TObject);
begin

  with ComboBox1.Items do
  begin
    BeginUpdate;
    try
      Clear;
      AddObject(Format('%s (0x%8.8X)',['IDLE',IDLE_PRIORITY_CLASS]),
                TObject(IDLE_PRIORITY_CLASS));
      AddObject(Format('%s (0x%8.8X)',['BELOW_NORMAL',BELOW_NORMAL_PRIORITY_CLASS]),
                TObject(BELOW_NORMAL_PRIORITY_CLASS));
      AddObject(Format('%s (0x%8.8X)',['NORMAL',NORMAL_PRIORITY_CLASS]),
                TObject(NORMAL_PRIORITY_CLASS));
      AddObject(Format('%s (0x%8.8X)',['ABOVE_NORMAL',ABOVE_NORMAL_PRIORITY_CLASS]),
                TObject(ABOVE_NORMAL_PRIORITY_CLASS));
      AddObject(Format('%s (0x%8.8X)',['HIGH',HIGH_PRIORITY_CLASS]),
                TObject(HIGH_PRIORITY_CLASS));
      AddObject(Format('%s (0x%8.8X)',['REALTIME',REALTIME_PRIORITY_CLASS]),
                TObject(REALTIME_PRIORITY_CLASS));

    finally
      EndUpdate;
    end;
  end;

end;
自プロセスの優先順位クラスを取得して表示します。
{$WARN SYMBOL_PLATFORM OFF}

procedure TForm1.Button1Click(Sender: TObject);
var
  PriorityClass: DWORD;
  I: Integer;
begin

  PriorityClass := GetPriorityClass(GetCurrentProcess);

  with ComboBox1 do
  begin
    for I := 0 to Items.Count - 1 do
    begin
      if DWORD(Items.Objects[I]) = PriorityClass then
      begin
        ItemIndex := I;
        Exit;
      end;
    end;

    ItemIndex := -1;
  end;

end;
今度は選択された優先順位クラスを自プロセスに設定します。
procedure TForm1.Button2Click(Sender: TObject);
var
  PriorityClass: DWORD;
begin

  with ComboBox1 do
  begin
    if ItemIndex < 0 then
    begin
      Exit;
    end;

    PriorityClass := DWORD(Items.Objects[ItemIndex]);
    Win32Check(SetPriorityClass(GetCurrentProcess,PriorityClass));
  end;

end;
Windowsにおけるスケジューリングのメカニズムは非常に複雑で、優先順位が実行中に動的に変更されるなど、単純に優先順位クラスなどで決まるわけではありません。このあたりをきちんと理解するためにはAdvanced Windows 第5版 上 (amazon)の"7.8 スレッドの優先度"、"7.9 優先度クラスの概要"、"7.10 プログラミングの優先度"やインサイドWindows 第6版 上 (amazon) の"5.7 スレッドのスケジューリング"などを読むことをお勧めします。

→GetPriorityClassとSetPriorityClassで優先順位クラスを取得/設定する (Gist)

2013年8月21日

CreateProcessで優先順位を指定してプログラムを起動する

優先順位クラス (Priority class)を指定してプロセスを起動するにはWin32APIのCreateProcess関数 (en)の第6パラメータ(dwCreationFlags)に優先順位クラスを指定します。

Delphi XE2およびそれ以前のバージョンではWindows.pasにBELOW_NORMAL_PRIORITY_CLASSとABOVE_NORMAL_PRIORITY_CLASSが定義されていないので、まずこれらを定義します。
{$IF RTLVersion < 24}
const
  BELOW_NORMAL_PRIORITY_CLASS = $00004000;
  {$EXTERNALSYM ABOVE_NORMAL_PRIORITY_CLASS}
  ABOVE_NORMAL_PRIORITY_CLASS = $00008000;
  {$EXTERNALSYM ABOVE_NORMAL_PRIORITY_CLASS}
{$IFEND}
フォームにEditとComboBox、Buttonをひとつずつ配置し、フォームのOnCreateイベントでEditとComboBoxに値を格納します。
procedure TForm1.FormCreate(Sender: TObject);
begin

  Edit1.Text := '%windir%\notepad.exe';

  with ComboBox1.Items do
  begin
    BeginUpdate;
    try
      Clear;
      AddObject(Format('%s (0x%8.8X)',['IDLE',IDLE_PRIORITY_CLASS]),
                TObject(IDLE_PRIORITY_CLASS));
      AddObject(Format('%s (0x%8.8X)',['BELOW_NORMAL',BELOW_NORMAL_PRIORITY_CLASS]),
                TObject(BELOW_NORMAL_PRIORITY_CLASS));
      AddObject(Format('%s (0x%8.8X)',['NORMAL',NORMAL_PRIORITY_CLASS]),
                TObject(NORMAL_PRIORITY_CLASS));
      AddObject(Format('%s (0x%8.8X)',['ABOVE_NORMAL',ABOVE_NORMAL_PRIORITY_CLASS]),
                TObject(ABOVE_NORMAL_PRIORITY_CLASS));
      AddObject(Format('%s (0x%8.8X)',['HIGH',HIGH_PRIORITY_CLASS]),
                TObject(HIGH_PRIORITY_CLASS));
      AddObject(Format('%s (0x%8.8X)',['REALTIME',REALTIME_PRIORITY_CLASS]),
                TObject(REALTIME_PRIORITY_CLASS));

    finally
      EndUpdate;
    end;
  end;

  with ComboBox1 do
  begin
    ItemIndex := Items.IndexOfObject(TObject(NORMAL_PRIORITY_CLASS));
  end;

end;
優先順位を指定してプロセスを起動します。
{$WARN SYMBOL_PLATFORM OFF}

procedure TForm1.Button1Click(Sender: TObject);
var
  ApplicationName: String;
  CreationFlags: DWORD;
  StartupInfo: TStartupInfo;
  ProcessInformation: TProcessInformation;
  Length: Integer;
begin

  Length := ExpandEnvironmentStrings(PChar(Edit1.Text),nil,0);
  SetLength(ApplicationName,Length);
  ExpandEnvironmentStrings(PChar(Edit1.Text),PChar(ApplicationName),Length);
  UniqueString(ApplicationName);

  with ComboBox1 do
  begin
    if ItemIndex < 0 then
    begin
      Exit;
    end;

    CreationFlags := DWORD(Items.Objects[ItemIndex]);
  end;

  FillChar(StartupInfo,SizeOf(StartupInfo),0);
  StartupInfo.cb := SizeOf(StartupInfo);

  FillChar(ProcessInformation,SizeOf(ProcessInformation),0);

  Win32Check(CreateProcess(PChar(ApplicationName),nil,nil,nil,False,
                           CreationFlags,nil,nil,
                           StartupInfo,ProcessInformation));

  CloseHandle(ProcessInformation.hProcess);
  CloseHandle(ProcessInformation.hThread);

end;
ここではEditに入力された起動対象プログラムに%windir%などの環境変数を使用することを前提としているため、Win32APIのExpandEnvironmentStrings関数 (en)で展開しています。

→優先順位クラスを指定してプロセスを起動する (Gist)

2013年8月5日

CopyFileExを使う

DelphiでファイルをコピーするときはWin32APIのCopyFile関数 (en)か、これをラッピングした(System.)IOUtilsのTFile.Copyなどを使うのが普通ですが、大きめのファイルだったり遅いデバイスだったり、あるいはその両方で、ファイルコピーに5秒以上かかるとWindowsに"応答なし"と判断されてしまうことになります。ファイルコピーを別スレッドで行ってもよいのですが(TFile.DoCopyの実装を見る限りPOSIX環境ではこれしかなさそう)、Windows環境であればWin32APIのCopyFileEx関数 (en)を使い、コールバック関数内でApplication.ProcessMessagesを呼び出すことでこの問題を回避することができます。ではまず(Winapi.)Windows.pas上のCopyFileExの定義を見てみましょう。
type
  TFNProgressRoutine = TFarProc;

function CopyFileEx(lpExistingFileName, lpNewFileName: LPWSTR;
  lpProgressRoutine: TFNProgressRoutine; lpData: Pointer; pbCancel: PBool;
  dwCopyFlags: DWORD): BOOL; stdcall;
コールバック関数の型はTFNProgressRoutine=TFarProcと定義されていますが、TFarProcはというと、
TFarProc = Pointer;
となっており、やる気のなさ満点です(間違っちゃいないけど)。そこでまずCopyProgressRoutineコールバック関数 (en)の定義から用意します。
type
  TCopyProgressRoutine = function (TotalFileSize: Int64;
                                   TotalBytesTransferred: Int64;
                                   StreamSize: Int64;
                                   StreamBytesTransferred: Int64;
                                   dwStreamNumber: DWORD;
                                   dwCallbackReason: DWORD;
                                   hSourceFile: THandle;
                                   hDestinationFile: THandle;
                                   lpData: Pointer): DWORD; stdcall;
これを使ってCopyFileEx関数を再定義します。
function CopyFileEx(lpExistingFileName: PChar;
                    lpNewFileName: PChar;
                    lpProgressRoutine: TCopyProgressRoutine;
                    lpData: Pointer;
                    pbCancel: PBool;
                    dwCopyFlags: DWORD): BOOL; stdcall; external kernel32
{$IFDEF UNICODE}
                    name 'CopyFileExW';
{$ELSE}
                    name 'CopyFileExA';
{$ENDIF}
{$EXTERNALSYM CopyFileEx}

これらの定義を使ってファイルをコピーしてみましょう。まずフォーム上にコピー元ファイル名とコピー先ファイル名を入力するためのEditを2つとコピー開始のButton、途中経過表示用のLabelを配置します。
{$WARN SYMBOL_PLATFORM OFF}
const
  COPY_FILE_NO_BUFFERING = $00001000;

function CopyProgressFunc(TotalFileSize: Int64;
                          TotalBytesTransferred: Int64;
                          StreamSize: Int64;
                          StreamBytesTransferred: Int64;
                          dwStreamNumber: DWORD;
                          dwCallbackReason: DWORD;
                          hSourceFile: THandle;
                          hDestinationFile: THandle;
                          lpData: Pointer): DWORD; stdcall;
var
  TBT: Extended;
  TFS: Extended;
begin

  TFS := TotalFileSize;
  TBT := TotalBytesTransferred;

  with TObject(lpData) as TForm1 do
  begin
    if (TotalFileSize = 0) or (TotalBytesTransferred = 0) then
    begin
      Label1.Caption := '';
    end
    else
    begin
      Label1.Caption := Format('%.0n / %.0n bytes',[TBT,TFS]);
    end;
  end;

  Application.ProcessMessages;

  Result := PROGRESS_CONTINUE;

end;

procedure TForm1.Button1Click(Sender: TObject);
var
  Canceled: BOOL;
  CopyFlags: DWORD;
begin

  Button1.Enabled := False;
  try
    Canceled := False;

    CopyFlags := COPY_FILE_FAIL_IF_EXISTS;
    if CheckWin32Version(6,0) then
    begin
      CopyFlags := CopyFlags or COPY_FILE_NO_BUFFERING;
    end;

    Win32Check(CopyFileEx(PChar(Edit1.Text),PChar(Edit2.Text),
               CopyProgressFunc,Self,@Canceled,CopyFlags));

  finally
    Button1.Enabled := True;
  end;

end;
これでファイルのコピー中に途中経過を表示できるようになります。またApplication.ProcessMessagesを呼び出すことでWindowsに"応答なし"と判定されることもなくなります(ただしイベントハンドラへの再入には十分注意が必要です)。

ここでは大きいファイルをコピーすることを想定しているため、Windows Vista以降ではdwCopyFlagsにCOPY_FILE_NO_BUFFERINGを追加指定しています(COPY_FILE_NO_BUFFERINGには功罪両面ありますが)。またファイルの上書きを許す場合はCopyFlagsにCOPY_FILE_FAIL_IF_EXISTSではなくて0を指定します(CopyFlagsにCOPY_FILE_FAIL_IF_EXISTSを指定したときにコピー先ファイルが存在しているとCopyFileExの戻値は0となり、GetLastError (en)はERROR_FILE_EXISTSを返します)。

さらにコピーの途中でキャンセルできるようにしてみます。フォームにキャンセル用のButtonと、privateメンバにBoolean型のフィールドFAbortedを追加します。
function CopyProgressFunc(TotalFileSize: Int64;
                          TotalBytesTransferred: Int64;
                          StreamSize: Int64;
                          StreamBytesTransferred: Int64;
                          dwStreamNumber: DWORD;
                          dwCallbackReason: DWORD;
                          hSourceFile: THandle;
                          hDestinationFile: THandle;
                          lpData: Pointer): DWORD; stdcall;
var
  TBT: Extended;
  TFS: Extended;
begin

  TFS := TotalFileSize;
  TBT := TotalBytesTransferred;

  with TObject(lpData) as TForm1 do
  begin
    if (TotalFileSize = 0) or (TotalBytesTransferred = 0) then
    begin
      Label1.Caption := '';
    end
    else
    begin
      Label1.Caption := Format('%.0n / %.0n bytes',[TBT,TFS]);
    end;

    Result := PROGRESS_CONTINUE;

    Application.ProcessMessages;
    if FAborted = True then
    begin
      Result := PROGRESS_CANCEL;
    end;
  end;

end;

procedure TForm1.Button1Click(Sender: TObject);
var
  Canceled: BOOL;
  CopyFlags: DWORD;
begin

  FAborted := False;

  Button1.Enabled := False;
  try
    Canceled := False;

    CopyFlags := COPY_FILE_FAIL_IF_EXISTS;
    if CheckWin32Version(6,0) then
    begin
      CopyFlags := CopyFlags or COPY_FILE_NO_BUFFERING;
    end;

    Win32Check(CopyFileEx(PChar(Edit1.Text),PChar(Edit2.Text),
               CopyProgressFunc,Self,@Canceled,CopyFlags));

  finally
    Button1.Enabled := True;
  end;

end;

procedure TForm1.Button2Click(Sender: TObject);
begin

  FAborted := True;
  
end;
こんな感じです。コールバック関数がPROGRESS_CANCELを返してファイルコピーをキャンセルしたときはCopyFileExの戻値は0(エラー)となり、GetLastErrorはERROR_REQUEST_ABORTEDを返します。

さて、Delphi 2009以降でコールバックといえば無名メソッド、という連想が働きますが、それはまた次回。

→Win32APIのCopyFileExのコールバックを受け入れる (Gist)

2012年12月10日

OVERFLOWCHECKS/RANGECHECKSオプションの効果

このアーティクルはDelphi Advent Calendar 2012に参加しています(7日ぶり2回目)。

Delphiにはオーバフローチェックと範囲チェックというコンパイラオプションがあります。

オーバーフローのチェック(Delphi) - RAD Studio XE3
範囲チェック - RAD Studio XE3

いずれもプロジェクトオプションのコンパイラで指定するか、{$OVERFLOWCHECKS ON|OFF}{$RANGECHECKS ON|OFF}で任意の範囲に対して指定することができます。しかしデフォルトの状態ではどちらもOFFなので、ONにした場合の

オーバーフローのチェックを有効にすると,プログラムは遅くなり,またいくらか大きくなるため,{$Q+} はデバッグにのみ使用してください。

範囲チェックを有効にすると、プログラムの処理速度が遅くなり、サイズも多少大きくなります。

が実際にどのようなことを示しているのかを知っている人は意外に少ないのではないでしょうか。そこでこれらのオプションによるペナルティがどのようなものなのかを確認してみます(Delphi XE2/Windows x86/Debugビルドで検証)。

まず{$OVERFLOWCHECKS ON}(短縮形{$Q+})です。
var
  a: Integer;
  b: Integer;
  c: Integer;
begin
{$OVERFLOWCHECKS ON}
  a := $44444444;
  b := $44444444;
  c := a + b;
{$OVERFLOWCHECKS OFF}
end;
このコードは以下のように展開されます。

Unit1.pas.36: a := $44444444;
0051139C C745F844444444   mov [ebp-$08],$44444444
Unit1.pas.37: b := $44444444;
005113A3 C745F444444444   mov [ebp-$0c],$44444444
Unit1.pas.38: c := a + b;
005113AA 8B45F8           mov eax,[ebp-$08]
005113AD 0345F4           add eax,[ebp-$0c]
005113B0 7105             jno $005113b7
005113B2 E8BD39EFFF       call @IntOver
005113B7 8945F0           mov [ebp-$10],eax
赤で示した2行が{$OVERFLOWCHECKS ON}で追加される命令になります。直前のadd命令の結果、OF(overflow flag)がセットされていればIntOver(System.pasのprocedure _IntOver)を呼び出して例外EIntOverflowが生成されます。{$OVERFLOWCHECKS ON}とすることで、特定の整数算術演算(+,-,*,Abs,Sqr,Succ,Pred,Inc,および Dec)毎にこのコードが追加で生成される、ということのようです。

一方{$RANGECHECKS ON}(短縮形{$R+})ですが、これには配列および文字列の添字のチェックとスカラ型/部分範囲型変数への代入時の範囲チェックの2つの効果があります。まず添字のチェックですが、ちょっとわかりづらいので{$RANGECHECKS OFF}のものと両方を並べてみます。
var
  s: String;
  c: Char;
begin
  s := 'TEST';
  c := s[6];
{$RANGECHECKS ON}
  c := s[6];
{$RANGECHECKS OFF}
end;
このコードは以下のように展開されます。

Unit1.pas.52: c := s[6];
00511464 8B45F8           mov eax,[ebp-$08]
00511467 668B400A         mov ax,[eax+$0a]
0051146B 668945F6         mov [ebp-$0a],ax
Unit1.pas.54: c := s[6];
0051146F B806000000       mov eax,$00000006
00511474 8B55F8           mov edx,[ebp-$08]
00511477 48               dec eax
00511478 85D2             test edx,edx
0051147A 7405             jz $00511481
0051147C 3B42FC           cmp eax,[edx-$04]
0051147F 7205             jb $00511486
00511481 E8E638EFFF       call @BoundErr
00511486 40               inc eax
00511487 668B4442FE       mov ax,[edx+eax*2-$02]
0051148C 668945F6         mov [ebp-$0a],ax
{$RANGECHECKS OFF}の場合は単に文字列の格納されているアドレスに添字-(1*SizeOf(Char))を足した場所にアクセスしているだけですが、{$RANGECHECKS ON}では空文字列かどうかのチェック(赤字)と文字列長以内かどうかのチェック(青字)が行われていることを含め、添字の一時的なデクリメント(文字列の添字が1オリジンなので)など、結構複雑な処理が行われていることがわかります(こちらは例外ERangeErrorが生成されます)。

最後に部分範囲型の変数への代入を見てみます。
type
  TSubInt = 8..15;
var
  a: TSubInt;
  b: TSubInt;
  c: TSubInt;
begin
{$RANGECHECKS ON}
  a := 8;
  b := 8;
  c := a + b;
  a := 9;
  b := 8;
  c := a - b;
{$RANGECHECKS OFF}
end;
加算と減算の両方を確認してみます。

Unit1.pas.69: a := 8;
005114D8 C645FB08         mov byte ptr [ebp-$05],$08
Unit1.pas.70: b := 8;
005114DC C645FA08         mov byte ptr [ebp-$06],$08
Unit1.pas.71: c := a + b;
005114E0 33C0             xor eax,eax
005114E2 8A45FB           mov al,[ebp-$05]
005114E5 33D2             xor edx,edx
005114E7 8A55FA           mov dl,[ebp-$06]
005114EA 03C2             add eax,edx
005114EC 83C0F8           add eax,-$08
005114EF 83F807           cmp eax,$07
005114F2 7605             jbe $005114f9
005114F4 E87338EFFF       call @BoundErr
005114F9 83C008           add eax,$08
005114FC 8845F9           mov [ebp-$07],al
Unit1.pas.72: a := 9;
005114FF C645FB09         mov byte ptr [ebp-$05],$09
Unit1.pas.73: b := 8;
00511503 C645FA08         mov byte ptr [ebp-$06],$08
Unit1.pas.74: c := a - b;
00511507 33C0             xor eax,eax
00511509 8A45FB           mov al,[ebp-$05]
0051150C 33D2             xor edx,edx
0051150E 8A55FA           mov dl,[ebp-$06]
00511511 2BC2             sub eax,edx
00511513 83C0F8           add eax,-$08
00511516 83F807           cmp eax,$07
00511519 7605             jbe $00511520
0051151B E84C38EFFF       call @BoundErr
00511520 83C008           add eax,$08
00511523 8845F9           mov [ebp-$07],al
加算、減算とも計算後に一時的に部分範囲の最小値を引いて、部分範囲におさまっているかどうかのチェックを行い(赤字)、改めて最小値を足す(青字)など、これもまた複雑な処理になっています。

ということで、オーバフローチェックはFLAGSレジスタのOFを検査するだけなので比較的ペナルティは小さく、オーバフローを検出したい状況では積極的にONにしても問題なさそうです。一方範囲チェックは範囲の最小値が0でないと処理が複雑になることもあり、明示的に必要な範囲チェックのコードを記述したほうがいいような気もします。

2012年10月4日

ファイルがSSDに書き込まれるかどうかを調べる(2)

前回の続きです。パート2としてATA8-ACSを使用して"nominal media rotation rate"を取得する方法を試してみます(こちらもNyaRuRuさんのコードそのままなので詳細な説明は省略します)。

まずはDeviceIOControlで使用する構造体、定数などを定義します。
type
  { ATA_PASS_THROUGH_EX }
  _ATA_PASS_THROUGH_EX = packed record
    Length: Word;
    AtaFlags: Word;
    PathId: UCHAR;
    TargetId: UCHAR;
    Lun: UCHAR;
    ReservedAsUchar: UCHAR;
    DataTransferLength: ULONG;
    TimeOutValue: ULONG;
    ReservedAsUlong: ULONG;
    DataBufferOffset: ULONG_PTR;
    PreviousTaskFile: array [0..7] of UCHAR;
    CurrentTaskFile: array [0..7] of UCHAR;
  end;
  {$EXTERNALSYM _ATA_PASS_THROUGH_EX}
  ATA_PASS_THROUGH_EX = _ATA_PASS_THROUGH_EX;
  {$EXTERNALSYM  ATA_PASS_THROUGH_EX}
  TAtaPassThroughEx   = _ATA_PASS_THROUGH_EX;
  PAtaPassThroughEx   = ^TAtaPassThroughEx;

  { ATAIdentifyDeviceQuery }
  TATAIdentifyDeviceQuery = packed record
    header: ATA_PASS_THROUGH_EX;
    data: array [0..255] of Word;
  end;

const
{$IF RTLVersion < 22.0}
  FILE_DEVICE_CONTROLLER  = $00000004;
  {$EXTERNALSYM FILE_DEVICE_CONTROLLER}

  FILE_READ_ACCESS        = $0001;
  {$EXTERNALSYM FILE_READ_ACCESS}

  FILE_WRITE_ACCESS       = $0002;
  {$EXTERNALSYM FILE_WRITE_ACCESS}
{$IFEND}

  ATA_FLAGS_DRDY_REQUIRED = $01;
  ATA_FLAGS_DATA_IN       = $02;
  ATA_FLAGS_DATA_OUT      = $04;
  ATA_FLAGS_48BIT_COMMAND = $08;
  ATA_FLAGS_USE_DMA       = $10;
  ATA_FLAGS_NO_MULTIPLE   = $20;

  IOCTL_SCSI_BASE         = FILE_DEVICE_CONTROLLER;
  IOCTL_ATA_PASS_THROUGH  = (IOCTL_SCSI_BASE shl 16) or
                            ((FILE_READ_ACCESS or FILE_WRITE_ACCESS) shl 14) or
                            ($040B shl 2) or
                            (METHOD_BUFFERED);
FILE_DEVICE_CONTROLLER、FILE_READ_ACCESS、FILE_WRITE_ACCESSはDelphi XE以降では定義済ですので、Delphi 2009およびそれ以前のバージョン用に定義しています。

これらを使用して物理ドライブ名"\\.\PhysicalDrive#"で指定したドライブが"nominal media rotation rate"かどうかを調べる関数です。
function HasNominalMediaRotationRate(const PhysicalDrivePath: String): Boolean;
var
  h: THandle;
  ATAIdentifyDeviceQuery: TATAIdentifyDeviceQuery;
  RSize: DWORD;
begin

  h := CreateFile(PChar(PhysicalDrivePath),GENERIC_READ or GENERIC_WRITE,
                  FILE_SHARE_READ or FILE_SHARE_WRITE,nil,
                  OPEN_EXISTING,FILE_ATTRIBUTE_NORMAL,0);
  if h = INVALID_HANDLE_VALUE then
  begin
    RaiseLastOSError;
  end;

  try
    FillChar(ATAIdentifyDeviceQuery,SizeOf(ATAIdentifyDeviceQuery),0);
    with ATAIdentifyDeviceQuery do
    begin
      header.Length := SizeOf(header);
      header.AtaFlags := ATA_FLAGS_DATA_IN;
      header.DataTransferLength := SizeOf(data);
      header.TimeOutValue := 3;  // sec
      header.DataBufferOffset := SizeOf(header);
      header.CurrentTaskFile[6] := $EC;  // ATA IDENTIFY DEVICE command
    end;

    RSize := 0;
    if DeviceIoControl(h,IOCTL_ATA_PASS_THROUGH,
                       @ATAIdentifyDeviceQuery,SizeOf(ATAIdentifyDeviceQuery),
                       @ATAIdentifyDeviceQuery,SizeOf(ATAIdentifyDeviceQuery),
                       RSize,nil) = False then
    begin
      RaiseLastOSError;
    end;

    Result := (ATAIdentifyDeviceQuery.data[217] = 1);

  finally
    CloseHandle(h);
  end;

end;
Trueが返ってくればそのドライブはnominal media rotation rateである、つまりSSDと判断できる、ということになります。こちらの方法はデバイスがATA8-ACSに対応していればWindows 2000およびそれ以降のすべてのOSで使用できますが、Windows Vista以降では管理者権限が必要になります。Delphiで作ったアプリケーションが管理者権限を要求するようにする方法についてはWindows Vista上で管理者権限を要求するアプリケーションを作成するを参照してください。なおWindows Vista以降の環境で管理者権限を要求するアプリケーションをデバッグするときはDelphiのIDEそのものも管理者権限で実行する必要があるようですので注意してください。

ファイル名/パス名から物理ドライブ番号("\\.\PhysicalDrive#"の#)を取得する方法は前回のものを使用できますので、こちらもファイル/パスがSSD上に書き込まれるかどうかを調べてみます。
var
  Index: Integer;
  Filename: String;
  PhysicalDrives: TIntegerDynArray;
  PhysicalDrivePath: String;
  IsSSD: Boolean;
begin

  Filename := "C:\";  // 例: "C:\"を調べます

  SetLength(PhysicalDrives,0);
  PathnameToPhysicalDriveNumber(Filename,PhysicalDrives);

  try
    IsSSD := False;
    for Index := Low(PhysicalDrives) to High(PhysicalDrives) do
    begin
      PhysicalDrivePath := Format('\\.\PhysicalDrive%d',[PhysicalDrives[Index]]);
      try
        IsSSD := IsSSD or HasNominalMediaRotationRate(PhysicalDrivePath);

      except
        { Ignore }
      end;

      if IsSSD = True then
      begin
        Break;
      end;
    end;

    if IsSSD = True then
    begin
      MessageDlg(Format('ファイル ''%s'' はSSDに書き込まれます。',[Filename]),
                 mtInformation,[mbOk],0);
    end
    else
    begin
      MessageDlg(Format('ファイル ''%s'' はSSDには書き込まれません。',[Filename]),
                 mtInformation,[mbOk],0);
    end;

  finally
    SetLength(PhysicalDrives,0);
  end;

end;
OSによって判定方法を切り替えるのであれば、
if CheckWin32Version(6,1) = True then
begin
  { Windows 7 or later }
  IsSSD := IsSSD or HasNoSeekPenalty(PhysicalDrivePath);
end
else
begin
  { Windows Vista or earlier }
  IsSSD := IsSSD or HasNominalMediaRotationRate(PhysicalDrivePath);
end;
とすればよいのですが、こうしたところでアプリケーション全体としては管理者権限が必要になってしまうので微妙な感じです(Vistaを考えなければ管理者権限を要求する必要がなくなりますが…)。

2012年10月3日

ファイルがSSDに書き込まれるかどうかを調べる(1)

プログラムの動作ログをファイルに記録するということはよくあることだと思いますが、単にCreateFile (en)でファイルをオープンするだけだと書き込み内容がOSでキャッシュされてしまい、OSがクラッシュしたり突然の電源断で書き込み内容の一部が失われてしまう可能性があります。これを防ぐにはMSDNのCreateFileのCaching Behaviorの説明に

If FILE_FLAG_WRITE_THROUGH is used but FILE_FLAG_NO_BUFFERING is not also specified, so that system caching is in effect, then the data is written to the system cache but is flushed to disk without delay.

てきとうな訳: FILE_FLAG_NO_BUFFERINGを指定せずにFILE_FLAG_WRITE_THROUGHを指定すると、システムキャッシュは有効となり、データはWindowsのシステムキャッシュに書き込まれますがディスクには遅延なくフラッシュされます。

とあるように、CreateFileの第6パラメータdwFlagsAndAttributesにFILE_FLAG_WRITE_THROUGHを指定します。

しかし大量のログを保存するようなケースで保存先がSSDだと、FILE_FLAG_WRITE_THROUGHの指定によりSSDの劣化が通常よりも早く進行することが予想されます。ということで保存先がSSDかどうかでこれらのフラグを付加するかどうかを決めるようにすればいい、ということになります。しかしドライブがSSDかどうかについては、(1)DeviceIOControl (en)でPropertyIdにStorageDeviceSeekPenaltyPropertyを指定したIOCTL_STORAGE_QUERY_PROPERTYを発行してDEVICE_SEEK_PENALTY_DESCRIPTOR構造体のIncursSeekPenaltyが0(False)になっている("no seek penalty")、(2)ATA8-ACSでドライブの回転数を取得してNominal Media Rotation Rate(0x01)になっている、のどちらかで調べることができる、ということまではわかったものの、さて実際のコード例はというとなかなか参考になるものがなく、手詰まりになっていました。

ところがその数日後、NyaRuRuさんがほぼそのまんまの

SSD なら動作を変えるアプリケーションを作る - NyaRuRuが地球にいたころ

という記事を書いているのを見つけました。これだけきちんとしたサンプルがあればDelphiに置き換えるのも簡単です。ということでパート1として(1)の"no seek penalty"を取得する方法を試してみます(以下NyaRuRuさんのコードそのままなので詳細な説明は省略します)。

まずはDeviceIOControlで使用する構造体、定数などを定義します。
{$IF RTLversion < 22.0}
const
  FILE_READ_DATA               = $0001;
  {$EXTERNALSYM FILE_READ_DATA}

  FILE_READ_ATTRIBUTES         = $0080;
  {$EXTERNALSYM FILE_READ_ATTRIBUTES}

  FILE_DEVICE_MASS_STORAGE     = $0000002d;
  {$EXTERNALSYM FILE_DEVICE_MASS_STORAGE}

  IOCTL_STORAGE_BASE           = FILE_DEVICE_MASS_STORAGE;
  {$EXTERNALSYM IOCTL_STORAGE_BASE}

  FILE_ANY_ACCESS              = 0;
  {$EXTERNALSYM FILE_ANY_ACCESS}

  METHOD_BUFFERED              = 0;
  {$EXTERNALSYM METHOD_BUFFERED}

  IOCTL_STORAGE_QUERY_PROPERTY = (IOCTL_STORAGE_BASE shl 16) or
                                 (FILE_ANY_ACCESS shl 14) or
                                 ($0500 shl 2) or
                                 (METHOD_BUFFERED);
  {$EXTERNALSYM IOCTL_STORAGE_QUERY_PROPERTY}
{$IFEND}

type
  { STORAGE_PROPERTY_ID }
  _STORAGE_PROPERTY_ID = (
    StorageDeviceProperty                 =  0,
    StorageAdapterProperty                =  1,
    StorageDeviceIdProperty               =  2,
    StorageDeviceUniqueIdProperty         =  3,
    StorageDeviceWriteCacheProperty       =  4,
    StorageMiniportProperty               =  5,
    StorageAccessAlignmentProperty        =  6,
    StorageDeviceSeekPenaltyProperty      =  7,
    StorageDeviceTrimProperty             =  8,
    StorageDeviceWriteAggregationProperty =  9,
    StorageDeviceDeviceTelemetryProperty  = 10
  );
  {$EXTERNALSYM _STORAGE_PROPERTY_ID}
  STORAGE_PROPERTY_ID = _STORAGE_PROPERTY_ID;
  {$EXTERNALSYM  STORAGE_PROPERTY_ID}
  TStoragePropertyId  = _STORAGE_PROPERTY_ID;
  PStoragePropertyId  = ^TStoragePropertyId;

  { STORAGE_QUERY_TYPE }
  _STORAGE_QUERY_TYPE = (
    PropertyStandardQuery   = 0,
    PropertyExistsQuery     = 1,
    PropertyMaskQuery       = 2,
    PropertyQueryMaxDefined = 3
  );
  {$EXTERNALSYM _STORAGE_QUERY_TYPE}
  STORAGE_QUERY_TYPE = _STORAGE_QUERY_TYPE;
  {$EXTERNALSYM  STORAGE_QUERY_TYPE}
  TStorageQueryType  = _STORAGE_QUERY_TYPE;
  PStorageQueryType  = ^TStorageQueryType;

  { STORAGE_PROPERTY_QUERY }
  _STORAGE_PROPERTY_QUERY = packed record
    PropertyId: DWORD;
    QueryType: DWORD;
    AdditionalParameters: array[0..9] of Byte;
  end;
  {$EXTERNALSYM _STORAGE_PROPERTY_QUERY}
  STORAGE_PROPERTY_QUERY = _STORAGE_PROPERTY_QUERY;
  {$EXTERNALSYM  STORAGE_PROPERTY_QUERY}
  TStoragePropertyQuery  = _STORAGE_PROPERTY_QUERY;
  PStoragePropertyQuery  = ^TStoragePropertyQuery;

  { DEVICE_SEEK_PENALTY_DESCRIPTOR }
  _DEVICE_SEEK_PENALTY_DESCRIPTOR = packed record
    Version: DWORD;
    Size: DWORD;
    IncursSeekPenalty: ByteBool;
    Reserved: array[0..2] of Byte;
  end;
  {$EXTERNALSYM _DEVICE_SEEK_PENALTY_DESCRIPTOR}
  DEVICE_SEEK_PENALTY_DESCRIPTOR = _DEVICE_SEEK_PENALTY_DESCRIPTOR;
  {$EXTERNALSYM  DEVICE_SEEK_PENALTY_DESCRIPTOR}
  TDeviceSeekPenaltyDescriptor   = _DEVICE_SEEK_PENALTY_DESCRIPTOR;
  PDeviceSeekPenaltyDescriptor   = ^TDeviceSeekPenaltyDescriptor;
FILE_READ_DATA、FILE_READ_ATTRIBUTES、FILE_DEVICE_MASS_STORAGE、FILE_ANY_ACCESS、METHOD_BUFFERED、IOCTL_STORAGE_QUERY_PROPERTYはDelphi XE以降では定義済ですので、Delphi 2009およびそれ以前のバージョン用として定義しています。

これらを使用して物理ドライブ名"\\.\PhysicalDrive#"で指定したドライブが"no seek penalty"かどうかを調べる関数です。
function HasNoSeekPenalty(const PhysicalDrivePath: String): Boolean;
var
  h :THandle;
  StoragePropertyQuery: TStoragePropertyQuery;
  DeviceSeekPenaltyDescriptor: TDeviceSeekPenaltyDescriptor;
  RSize: DWORD;
begin

  h := CreateFile(PChar(PhysicalDrivePath),FILE_READ_ATTRIBUTES,
                  FILE_SHARE_READ or FILE_SHARE_WRITE,nil,
                  OPEN_EXISTING,FILE_ATTRIBUTE_NORMAL,0);
  if h = INVALID_HANDLE_VALUE then
  begin
    RaiseLastOSError;
  end;

  try
    with StoragePropertyQuery do
    begin
      PropertyId := Ord(StorageDeviceSeekPenaltyProperty);
      QueryType  := Ord(PropertyStandardQuery);
    end;

    FillChar(DeviceSeekPenaltyDescriptor,SizeOf(DeviceSeekPenaltyDescriptor),0);
    RSize := 0;
    if DeviceIoControl(h,IOCTL_STORAGE_QUERY_PROPERTY,
                       @StoragePropertyQuery,SizeOf(StoragePropertyQuery),
                       @DeviceSeekPenaltyDescriptor,SizeOf(DeviceSeekPenaltyDescriptor),
                       RSize,nil) = False then
    begin
      RaiseLastOSError;
    end;

    Result := not DeviceSeekPenaltyDescriptor.IncursSeekPenalty;

  finally
    CloseHandle(h);
  end;

end;
Trueが返ってくればそのドライブはseek penaltyがない、つまりSSDと判断できる、ということになります。ただしこの方法はWindows 7およびそれ以降でしか使用できません(そのかわり管理者権限は不要です)。

次にファイル名/パス名から物理ドライブ番号("\\.\PhysicalDrive#"の#)を取得する方法です。まず構造体、定数などの定義です。
type
  { DISK_EXTENT }
  _DISK_EXTENT = packed record
    DiskNumber: DWORD;
    StartingOffset: LARGE_INTEGER;
    ExtentLength: LARGE_INTEGER;
    Reserved: array [0..3] of Byte;
  end;
  {$EXTERNALSYM _DISK_EXTENT}
  DISK_EXTENT = _DISK_EXTENT;
  {$EXTERNALSYM  DISK_EXTENT}
  TDiskExtent = _DISK_EXTENT;
  PDiskExtent = ^TDiskExtent;

  { VOLUME_DISK_EXTENTS }
  _VOLUME_DISK_EXTENTS = packed record
    NumberOfDiskExtents: DWORD;
    Reserved: array [0..3] of Byte;
    Extents: array [0..0] of DISK_EXTENT;
  end;
  {$EXTERNALSYM _VOLUME_DISK_EXTENTS}
  VOLUME_DISK_EXTENTS = _VOLUME_DISK_EXTENTS;
  {$EXTERNALSYM  VOLUME_DISK_EXTENTS}
  TVolumeDiskExtents  =  VOLUME_DISK_EXTENTS;
  PVolumeDiskExtents  = ^TVolumeDiskExtents;

{$IF RTLVersion < 22.0}
const
  IOCTL_VOLUME_BASE                    = $00000056;
  {$EXTERNALSYM IOCTL_VOLUME_BASE}

  IOCTL_VOLUME_GET_VOLUME_DISK_EXTENTS = (IOCTL_VOLUME_BASE shl 16) or
                                         (FILE_ANY_ACCESS shl 14) or
                                         (0 shl 2) or
                                         (METHOD_BUFFERED);
  {$EXTERNALSYM IOCTL_VOLUME_GET_VOLUME_DISK_EXTENTS}
{$IFEND}
さきほどと同様にIOCTL_VOLUME_GET_VOLUME_DISK_EXTENTSはDelphi XE以降で定義済ですのでDelphi 2009およびそれ以前のバージョンでのみ定義が必要です。

指定したファイル名/パス名の存在する物理ドライブ番号を動的配列に格納する関数です。
uses
  Types;

procedure PathnameToPhysicalDriveNumber(const Path: String; var PhysicalDrives: TIntegerDynArray);
var
  h: THandle;
  I: Integer;
  MountPoint: String;
  VolumeName: String;
  Size: DWORD;
  RSize: DWORD;
  P: PVolumeDiskExtents;
begin

  SetLength(PhysicalDrives,0);

  { Pathname to mount point }
  Size := GetFullPathName(PChar(Path),0,nil,nil);
  SetLength(MountPoint,Size);
  if GetVolumePathName(PChar(Path),PChar(MountPoint),Size) = False then
  begin
    RaiseLastOSError;
  end;
  SetLength(MountPoint,StrLen(PChar(MountPoint)));

  { Mount point to logical volume name }
  Size := 50;  // Recomended size from http://msdn.microsoft.com/en-us/library/windows/desktop/aa364994.aspx
  SetLength(VolumeName,Size);
  if GetVolumeNameForVolumeMountPoint(PChar(MountPoint),PChar(VolumeName),Size) = False then
  begin
    RaiseLastOSError;
  end;
  SetLength(VolumeName,StrLen(PChar(VolumeName)));
  VolumeName := ExcludeTrailingPathDelimiter(VolumeName);

  { Open volume }
  h := CreateFile(PChar(VolumeName),FILE_READ_ATTRIBUTES,
                  FILE_SHARE_READ or FILE_SHARE_WRITE,nil,
                  OPEN_EXISTING,FILE_ATTRIBUTE_NORMAL,0);
  if h = INVALID_HANDLE_VALUE then
  begin
    RaiseLastOSError;
  end;

  try
    Size := SizeOf(TVolumeDiskExtents);
    P := AllocMem(Size);
    try
      FillChar(P^,Size,0);
      RSize := 0;
      if DeviceIoControl(h,IOCTL_VOLUME_GET_VOLUME_DISK_EXTENTS,
                         nil,0,
                         P,Size,
                         RSize,nil) = False then
      begin
        if GetLastError <> ERROR_MORE_DATA then
        begin
          RaiseLastOSError;
        end;

        Size := SizeOf(TVolumeDiskExtents) +
                SizeOf(DISK_EXTENT) * (P^.NumberOfDiskExtents - 1);
        ReallocMem(P,Size);
        FillChar(P^,Size,0);
        if DeviceIoControl(h,IOCTL_VOLUME_GET_VOLUME_DISK_EXTENTS,
                           nil,0,
                           P,Size,
                           RSize,nil) = False then
        begin
          RaiseLastOSError;
        end;
      end;

      SetLength(PhysicalDrives,P^.NumberOfDiskExtents);
      for I := 0 to P^.NumberOfDiskExtents - 1 do
      begin
        PhysicalDrives[I] := P^.Extents[I].DiskNumber;
      end;

    finally
      FreeMem(P);
    end;

  finally
    CloseHandle(h);
  end;

end;
これで第2パラメータPhysicalDrivesに物理ドライブ番号が格納されます。

これらの関数を組み合わせて指定したファイル/パスがSSD上に書き込まれるかどうかを調べてみます。
var
  Index: Integer;
  Filename: String;
  PhysicalDrives: TIntegerDynArray;
  PhysicalDrivePath: String;
  IsSSD: Boolean;
begin

  Filename := "C:\";  // 例: "C:\"を調べます

  SetLength(PhysicalDrives,0);
  PathnameToPhysicalDriveNumber(Filename,PhysicalDrives);

  try
    IsSSD := False;
    for Index := Low(PhysicalDrives) to High(PhysicalDrives) do
    begin
      PhysicalDrivePath := Format('\\.\PhysicalDrive%d',[PhysicalDrives[Index]]);
      try
        IsSSD := IsSSD or HasNoSeekPenalty(PhysicalDrivePath);

      except
        { Ignore }
      end;

      if IsSSD = True then
      begin
        Break;
      end;
    end;

    if IsSSD = True then
    begin
      MessageDlg(Format('ファイル ''%s'' はSSDに書き込まれます。',[Filename]),
                 mtInformation,[mbOk],0);
    end
    else
    begin
      MessageDlg(Format('ファイル ''%s'' はSSDには書き込まれません。',[Filename]),
                 mtInformation,[mbOk],0);
    end;

  finally
    SetLength(PhysicalDrives,0);
  end;

end;
ATA8-ACSでドライブの回転数を取得する方法については次のアーティクルで。

元ねたはもちろんNyaRuRuさんのSSD なら動作を変えるアプリケーションを作る - NyaRuRuが地球にいたころ。すばらしいサンプルを書いていただいたNyaRuRuさんに深く感謝いたします。

2012/10/05追記: CreateFileのフラグについて当初FILE_FLAG_NO_BUFFERINGとFILE_FLAG_WRITE_THROUGHの両方を指定するという記述がありましたが、FILE_FLAG_NO_BUFFERINGを指定したファイルへの書き込みにはFile Bufferingにあるように制限があり、通常の使用には向かないと考えられるため、この点を削除しました。

2012年9月11日

JVCL 3.46/3.47

JVCL(JEDI Visual Component Library)がアップデートされてVersion 3.46Version 3.47(JCL Version 2.4.1)になっています。

JEDI VCL for Delphi - Browse /JVCL 3/JVCL 3.46 at SourceForge.net
JEDI VCL for Delphi - Browse /JVCL 3/JVCL 3.47 at SourceForge.net

ただしJVCLのニュースグループにはGenerateDefines.pasの46行目がDelphi 2007/2009/2010/XEでコンパイルエラーになるという問題が報告されています。

ANN: JVCL 3.46 Released!

修正はSVNにチェックインされたようですが、とりあえずは該当箇所を

{$IFDEF HAS_UNITSCOPE}
System.Types,
{$ELSE HAS_UNITSCOPE}
Types,
{$ENDIF HAS_UNITSCOPE}

とすることで回避できます。

GenerateDefines.pasの問題を修正した3.47がリリースされています。

2012年4月19日

TRegistryを拡張する

DelphiのTRegistryはWin32APIのレジストリ (ja)のラッパですが、よく見てみるとRegistry Value Types(RegEnumValueに日本語の説明あり)のうちREG_BINARY(バイナリ)、REG_DWORD(32bit整数)、REG_SZ(文字列)、REG_EXPAND_SZ(展開可能文字列)しかサポートしておらず、REG_MULTI_SZ(複数行文字列)やREG_QWORD(64bit整数)の値を直接読み書きすることはできません。もちろんREG_SZやREG_BINARYで代用することは可能ですが、レジストリエディタで値を操作するときはやはりREG_MULTI_SZやREG_QWORDになっていたほうが何かと便利です。そこで今回はクラスヘルパを使ってこれらのデータ型のサポートを追加してみます。

まずクラスヘルパの宣言です。
uses
  Windows, Classes, Registry;

type
  TRegistryHelper = class helper for TRegistry
    function  ReadInt64(const Name: string): Int64;
    procedure WriteInt64(const Name: string; Value: Int64);
    procedure ReadStrings(const Name: String; Value: TStrings); overload;
    function  ReadStrings(const Name: String): String; overload;
    procedure WriteStrings(const Name: String; Value: TStrings); overload;
    procedure WriteStrings(const Name: String; Value: String); overload;
    class function  StringsToDoubleNulTerminated(Strings: TStrings): String; static;
    class procedure DoubleNulTerminatedToStrings(const Str: String; Strings: TStrings); static;
  end;
またWindowsユニットにREG_QWORDの定義が不足していますのでこれも定義しておきます。
const
  REG_QWORD = 11;
  {$EXTERNALSYM REG_QWORD}
最初にInt64の読み書きです。TRegistryの実装を見てみると、Delphi 2009まではRegQueryValueEx (ja)およびRegSetValueEx (ja)の戻値を直接確認していましたが、Delphi 2010以降ではLastErrorプロパティを追加した関係からCheckResultを使用するように変更されているので、ここではこれに従います。またエラー時に生成する例外のメッセージのためにRTLConstsユニットをusesに追加する必要があります。
uses
  RTLConsts;

function TRegistryHelper.ReadInt64(const Name: string): Int64;
var
  BufSize: Integer;
  DataType: Integer;
begin

  DataType := REG_NONE;
  BufSize := SizeOf(Int64);

{$IF RTLVersion >= 21.0}
  if CheckResult(RegQueryValueEx(CurrentKey,PChar(Name),nil,@DataType,PByte(@Result),@BufSize)) = False then
{$ELSE}
  if RegQueryValueEx(CurrentKey,PChar(Name),nil,@DataType,PByte(@Result),@BufSize) <> ERROR_SUCCESS then
{$IFEND}
  begin
    raise ERegistryException.CreateResFmt(@SRegGetDataFailed, [Name]);
  end;

  if DataType <> REG_QWORD then
  begin
    raise ERegistryException.CreateResFmt(@SInvalidRegType,[Name]);
  end;

end;

procedure TRegistryHelper.WriteInt64(const Name: string; Value: Int64);
var
  DataType: Integer;
begin

DataType := REG_QWORD;

{$IF RTLVersion >= 21.0}
  if CheckResult(RegSetValueEx(CurrentKey,PChar(Name),0,DataType,@Value,SizeOf(Int64))) = False then
{$ELSE}
  if RegSetValueEx(CurrentKey,PChar(Name),0,DataType,@Value,SizeOf(Int64)) <> ERROR_SUCCESS then
{$IFEND}
  begin
    raise ERegistryException.CreateResFmt(@SRegSetDataFailed, [Name]);
  end;

end;
次に複数行文字列です。RegQueryValueExとRegSetValueExでREG_MULTI_SZの値を読み書きする場合は、各行がNUL文字で終端されていて、最後に空行(NUL文字だけ)が付加される"double null terminated string"が使われるため、まずTStringsとの間の変換を行う処理を用意します。
class function TRegistryHelper.StringsToDoubleNulTerminated(Strings: TStrings): String;
var
  Index: Integer;
begin

  if Strings.Count > 0 then
  begin
    Result := '';
    for Index := 0 to Strings.Count - 1 do
    begin
      Result := Result + Strings.Strings[Index] + #0;
    end;
    Result := Result + #0;
  end
  else
  begin
    Result := #0 + #0;
  end;

end;

class procedure TRegistryHelper.DoubleNulTerminatedToStrings(const Str: String; Strings: TStrings);
var
  P: PChar;
  Start: PChar;
  S: String;
begin

  Strings.BeginUpdate;
  try
    Strings.Clear;

    P := PChar(Str);
    while P^ <> #0 do
    begin
      Start := P;
      while (P^ <> #0) do
      begin
        Inc(P);
      end;
      SetString(S,Start,P - Start);
      Strings.Add(S);
      Inc(P);
    end;

  finally
    Strings.EndUpdate;
  end;

end;
これらのメソッドを利用してTStringsを読み書きします。
procedure TRegistryHelper.ReadStrings(const Name: String; Value: TStrings);
var
  Len: Integer;
  Data: String;
  DataType: Integer;
begin

  Len := GetDataSize(Name);
  if Len > 0 then
  begin
    SetString(Data,nil,Len div SizeOf(Char));

    DataType := REG_NONE;
{$IF RTLVersion >= 21.0}
    if CheckResult(RegQueryValueEx(CurrentKey,PChar(Name),nil,@DataType,PByte(Data),@Len)) = False then
{$ELSE}
    if RegQueryValueEx(CurrentKey,PChar(Name),nil,@DataType,PByte(Data),@Len) <> ERROR_SUCCESS then
{$IFEND}
    begin
      raise ERegistryException.CreateResFmt(@SRegGetDataFailed,[Name]);
    end;

    if DataType <> REG_MULTI_SZ then
    begin
      raise ERegistryException.CreateResFmt(@SInvalidRegType,[Name]);
    end;

    SetLength(Data,Len div SizeOf(Char));

    DoubleNulTerminatedToStrings(Data,Value);
  end;

end;

procedure TRegistryHelper.WriteStrings(const Name: String; Value: TStrings);
var
  Data: String;
begin

  Data := StringsToDoubleNulTerminated(Value);

{$IF RTLVersion >= 21.0}
  if CheckResult(RegSetValueEx(CurrentKey,PChar(Name),0,REG_MULTI_SZ,
                 PChar(Data),Length(Data) * SizeOf(Char))) = False then
{$ELSE}
  if RegSetValueEx(CurrentKey,PChar(Name),0,REG_MULTI_SZ,
                   PChar(Data),Length(Data) * SizeOf(Char)) <> ERROR_SUCCESS then
{$IFEND}
  begin
    raise ERegistryException.CreateResFmt(@SRegSetDataFailed,[Name]);
  end;

end;
またTStringsではなく改行文字(#13#10)を含む通常のStringで読み書きするoverloadも用意してみました。
function TRegistryHelper.ReadStrings(const Name: String): String;
var
  SL: TStringList;
begin

  SL := TStringList.Create;
  try
    ReadStrings(Name,SL);
    Result := SL.Text;

  finally
    SL.Free;
  end;

end;

procedure TRegistryHelper.WriteStrings(const Name: String; Value: String);
var
  SL: TStringList;
begin

  SL := TStringList.Create;
  try
    SL.Text := Value;
    WriteStrings(Name,SL);

  finally
    SL.Free;
  end;

end;

2011年11月28日

JVCL 3.45リリース

JVCL(JEDI Visual Component Library)がアップデートされてVersion 3.45(JCL Version 2.3.1)になっています。

JEDI VCL for Delphi - Browse /JVCL 3/JVCL 3.45 at SourceForge.net

またAndreas HausladenさんがコマンドラインコンパイラDCC32/DCC64が付属していないDelphi/C++Builder XE2 Starter SKUのためのコンパイル済バイナリのインストーラをCodeCentralにアップロードしています(上記のリリースバージョンそのものではなく、JCLはsvn revision 3634、JVCLはsvn revision 13184から作成したものとのことです)。

28636 Jedi Code Library 2.4.0.4198r3634 BinaryInstaller for XE2
28637 Jedi Visual Component Library 3.45r13184 BinaryInstaller for XE2

元ねたはUpdated JCL and JVCL Binary Installers for XE2 | Andy’s Blog and Tools。

2011年11月10日

クラスヘルパ

クラスヘルパはDelphi 2007で導入された新機能で、クラスを継承することなく拡張するためのものです(Delphi 2007 HandbookにはDelphi 2007でDelphi 2006とのバイナリレベルでの互換性を確保するために導入された、とあります)。当初はクラスにしか適用できませんでしたが、Delphi 2010以降ではレコード型に対しても(レコードヘルパとして)適用することができます。しかしヘルパで定義したメソッドではpublicメンバにしかアクセスできないため、ある種のシンタックスシュガーのように考えればよいと思っていました。DelphiデベロッパチームシニアソフトウェアデベロッパのMat DeLongさん Mat DeLongさんのこのアーティクルを読むまでは。

Mat DeLong : Gaining access to private fields of a class Gaining access to private fields of a class in Delphi | Mat DeLong

これによると、private/protectedメンバであっても"Self."で修飾することでアクセスできる、と書かれています。なんですと?ということでDelphi 2007以降の各バージョンで確認してみました。
  • Delphi 2007: "Self."の有無に関わらずpublicのみアクセス可能
  • Delphi 2009: "Self."とすることでprivateはアクセスできるがなぜかprotectedはアクセス不可
  • Delphi 2010/XE/XE2: "Self."とすることでprivate/protectedもアクセス可能
Delphi 2010以降であればこの方法でより突っ込んだことができそうです。

またクラス ヘルパとレコード ヘルパ(Delphi)には

ただし、ソース コードの任意の場所で適用されるヘルパの数は、0 または 1 つだけです。
とあり、ひとつのクラスに複数のヘルパを適用することはできないのですが、ヘルパの構文として
type
  identifierName = class|record helper [(ancestor list)] for TypeIdentifierName
    memberList
  end;
とあり、継承したクラスヘルパを作成することで実質的に複数のヘルパを適用することができます。
type
  TFooHelper = class helper for TFoo
  public
    procedure Bar1;
  end;

  TFooHelperEx = class helper (TFooHelper) for TFoo
  public
    procedure Bar2;
  end;

var
  Foo: TFoo;
begin
  ...
  Foo.Bar1;  // TFooHelper.Bar1
  Foo.Bar2;  // TFooHelperEx.Bar2
  ...
こんな感じです。

2020/09/23追記: Mat DeLongさんの記事のリンクを更新しました。pmcgeeさん、情報ありがとうございます。

2011年8月30日

IntraWeb 9が無償に

DelphiにはIntraWeb(VCL for the Web)がバンドルされていますが、ANSI版Delphi(5/6/7/2005/2006/2007)に対応しているIntraWeb 9 Enterprise(9.0.42)をAtozed Softwareが無償で公開しています。

Atozed Software - IntraWeb 9 Enterprise is now free!

Atozedでアカウントを作成するだけでIntraWeb 9 Enterpriseのライセンスを取得することができるようになります。ただしANSI版のみ、バグ修正なし、サポートなしとのことです。

2011年7月23日

DDevExtensions 2.4リリース

Andreas HausladenさんのDDevExtensionsがアップデートされてVersion 2.4になっています。Delphi 2007/2009で[Shift]+[F3]による逆方向の検索ができるようになるなど、細かく新機能が追加されています。

DDevExtensions 2.4 | Andy’s Blog and Tools

2011年5月16日

IDE Fix Pack 4.1/DelphiSpeedUp 3.1リリース

Andreas HausladenさんのIDE Fix Pack 2007およびIDE Fix Pack 2009/2010/XEがアップデートされてVersion 4.1に、DelphiSpeedUpもDelphi 7/2007用がアップデートされてVersion 3.1になっています。IDE Fix Pack、DelphiSpeedUpともRCからの変更はないようです。

IDE Fix Pack 4.1, DelphiSpeedUp 3.1 | Andy’s Blog and Tools