Delphindo on WordPress

by: Mpu Gondrong

Membuat program berupa service di Windows NT/2K/XP adalah mudah sejak Delphi 5. Hal ini karena telah disediakan fasilitas dan unit khusus untuk itu. Namun kemudahan ini harus dibayar dengan membengkaknya ukuran program. Hare gene masih mikirin besarnya program ? Akan tetapi, kalo bisa kecil kenapa harus besar ?

Perkenalan saya dengan servicenya NT sebenarnya sudah lama, yaitu sejak 1999. Saat itu masih memakai Delphi v4.0 yang belum menyediakan secara khusus untuk membuat service. Beruntung ada yang telah membuat unit service ini sehingga keahlian saya tersalurkan, yaitu memakainya. Detil tentang service sendiri bagi saya kurang jelas. Bagi pembaca yang ingin mendalami soal service silakan bertanya kepada Paman Google.

Ketika kemarin-kemarin saya bergelut sedikit dengan service, hati kecil saya bertanya: “Mosok untuk membuat service sederhana perlu 400-an KB ?” Dengan memakai class TService program setidaknya berukuran 400-an KB di Delphi 6. Harganya murah memang, beberapa klik mouse saja. Namun bila repot sedikit, misalnya menggunakan unit service sendiri, hasilnya akan jauh lebih kecil.

Langkah pertama untuk membuat unit service sendiri kita mulai dari Google dan Torry. Saya lupa persisnya dari mana, tapi beberapa jenak kemudian didapatlah kerangka dan unit service yang cukup sederhana. Unit tersebut sudah siap pakai, dapat dikompilasi dan dijalankan dengan baik.

Cukup Saja Belum Cukup

Walau sudah memadai tapi kita dapat melakukan pembenahan lebih lanjut. Program berupa service umumnya berjalan di belakang dan berjenis console (non GUI). Program console tidak perlu neko-neko dengan tampilan sehingga banyak hal bisa kita hemat. Termasuk pula penggunaan VCL yang tidak perlu-perlu amat berwujud visual.

Beberapa langkah yang bisa kita lakukan:

• Meminimalkan unit yang digunakan, yaitu cukup Windows, WinSvc dan System (built-in) saja. Unit-unit tersebut kebanyakan hanya berupa header fungsi dalam Windows.
• Memudahkan dalam penggunaan unit, cukup memanggil 1 fungsi saja.
• Tidak perlu membuat unit berupa class karena toh 1 program hanya untuk 1 service saja.
• Tidak perlu multi-thread, tapi mudah untuk itu bila diperlukan. Thread utama cukup untuk memutar service hingga saat kematiannya tiba.
• Hanya parameter install (manual startup) dan uninstall saja yang diperlukan.
• Hanya start dan stop service saja yang perlu ditangani dari Service Manager.
• Menggunakan fasilitas event dari sistem operasi untuk memantau berhentinya service. Event ini perlu terutama bila kita ingin menggunakan mode overlapped dalam melakukan operasi input / output di Windows.

Lengkapnya unit service tersebut seperti di bawah ini.

unit uService;

interface

uses
  Windows, WinSvc;

type
  TServiceProc = procedure;

var
  FServiceStopEventHandle: THandle;

procedure DoService(ServiceName: string; SvcRun: TServiceProc);
function WaitForStop(TimeOut: DWord): Boolean;

implementation

var
  FServiceName: string;
  FSvcRun: TServiceProc;
  FServiceStatusHandle: SERVICE_STATUS_HANDLE;
  FServiceStatus: TServiceStatus;

function GetLastErrorText: string;
begin
  SetLength(Result, 512);
  SetLength(Result, FormatMessage(FORMAT_MESSAGE_FROM_SYSTEM or FORMAT_MESSAGE_ARGUMENT_ARRAY,
    nil, GetLastError, LANG_NEUTRAL, @Result[1], Length(Result), nil));
end;

procedure AddToMessageLog(const S: string);
var
  hEventSource: THandle;
begin
  hEventSource := RegisterEventSource(nil, @FServiceName[1]);
  if hEventSource > 0 then begin
    ReportEvent(hEventSource, EVENTLOG_ERROR_TYPE, 0, 0, nil, 1, 0, @S[1], nil);
    DeregisterEventSource(hEventSource);
  end;
end;

function ReportStatusToSCMgr(State, ExitCode, Wait:DWord): Bool;
begin
  with FServiceStatus do begin
    if (State = SERVICE_START_PENDING) then
      dwControlsAccepted := 0
    else dwControlsAccepted := SERVICE_ACCEPT_STOP;
    dwCurrentState := State;
    dwWin32ExitCode := ExitCode;
    dwWaitHint := Wait;
    if (State = SERVICE_RUNNING) or (State = SERVICE_STOPPED) then
      dwCheckPoint := 0
    else Inc(dwCheckPoint);
  end;
  Result := SetServiceStatus(FServiceStatusHandle, FServiceStatus);
  if not Result then AddToMessageLog('SetServiceStatus');
end;

procedure Handler(CtrlCode: DWord); stdcall;
begin
  case CtrlCode of
  SERVICE_CONTROL_STOP:
    begin
      ReportStatusToSCMgr(SERVICE_STOP_PENDING, NO_ERROR, 0);
      SetEvent(FServiceStopEventHandle);
      ReportStatusToSCMgr(SERVICE_STOPPED, NO_ERROR, 0);
      Exit;
    end;
  end;
  ReportStatusToSCMgr(FServiceStatus.dwCurrentState, NO_ERROR, 0);
end;

procedure ServiceMain;
begin
  FServiceStopEventHandle := CreateEvent(nil, True, False, nil);
  if FServiceStopEventHandle = 0 then begin
    AddToMessageLog('CreateEvent');
    Exit;
  end;
  FServiceStatusHandle := RegisterServiceCtrlHandler(@FServiceName[1], @Handler);
  if FServiceStatusHandle = 0 then begin
    ReportStatusToSCMgr(SERVICE_STOPPED, GetLastError, 0);
    Exit;
  end;
  FServiceStatus.dwServiceType := SERVICE_WIN32_OWN_PROCESS;
  FServiceStatus.dwServiceSpecificExitCode := 0;
  FServiceStatus.dwCheckPoint := 1;
  if not ReportStatusToSCMgr(SERVICE_START_PENDING, NO_ERROR, 3000) then begin
    ReportStatusToSCMgr(SERVICE_STOPPED, GetLastError, 0);
    Exit;
  end;
  if not ReportStatusToSCMgr(SERVICE_RUNNING, NO_ERROR, 0) then Exit;
  if Assigned(FSvcRun) then FSvcRun;
  CloseHandle(FServiceStopEventHandle);
  ReportStatusToSCMgr(SERVICE_STOPPED, NO_ERROR, 0);
end;

procedure SetupService(Install: Boolean);
var
  ServiceControlHandle, SCManagerHandle: SC_HANDLE;
  PrgPath: string;
begin
  SCManagerHandle := OpenSCManager(nil, nil, SC_MANAGER_ALL_ACCESS);
  if (SCManagerHandle > 0) then begin
    if Install then begin // install service
      PrgPath := ParamStr(0);
      ServiceControlHandle := CreateService(SCManagerHandle, @FServiceName[1],
        @FServiceName[1], SERVICE_ALL_ACCESS, SERVICE_WIN32_OWN_PROCESS,
        SERVICE_DEMAND_START, SERVICE_ERROR_NORMAL, @PrgPath[1], nil, nil, nil, nil, nil);
      if (ServiceControlHandle > 0) then Writeln(FServiceName, ': Install Ok.');
    end
    else begin // uninstall service
      ServiceControlHandle := OpenService(SCManagerHandle, @FServiceName[1], SERVICE_ALL_ACCESS);
      if (ServiceControlHandle > 0) and DeleteService(ServiceControlHandle) then
        Writeln(FServiceName, ': Uninstall Ok.');
    end;
    if (ServiceControlHandle > 0) then
      CloseServiceHandle(ServiceControlHandle)
    else Write(FServiceName, ': ', GetLastErrorText);
    CloseServiceHandle(SCManagerHandle);
  end
  else Write(FServiceName, ': ', GetLastErrorText);
end;

procedure DoService;
var
  S: string;
  FServiceTableEntry: array [0..1] of TServiceTableEntry;
begin
  FServiceName := ServiceName;
  FSvcRun := SvcRun;
  S := ParamStr(1);
  if (Length(S)>=2) and (S[1]='/') then begin
    case UpCase(S[2]) of
      'I': SetupService(True);
      'U': SetupService(False);
      else begin
        Writeln(FServiceName + ' usage help:'#13#10 +
          '/I = Install manual startup'#13#10 +
          '/U = Uninstall');
      end;
    end;
    Exit;
  end;
  // Setup service table which define all services in this process
  with FServiceTableEntry[0] do begin
    lpServiceName := @FServiceName[1];
    lpServiceProc := @ServiceMain;
  end;
  // Last entry in the table must have nil values to designate the end of the table
  with FServiceTableEntry[1] do begin
    lpServiceName := nil;
    lpServiceProc := nil;
  end;
  if not StartServiceCtrlDispatcher(FServiceTableEntry[0]) then
    AddToMessageLog('StartServiceCtrlDispatcher Error');
end;

function WaitForStop(TimeOut: DWord): Boolean;
begin
  Result := WaitForSingleObject(FServiceStopEventHandle, TimeOut) = WAIT_OBJECT_0;
end;

end.

Beeper Service

Sebagai contoh pemakaian unit uService ini kita lihat dalam service Beeper. Service ini hanya mengeluarkan beep (MessageBeep) setiap 5 detik. Untuk memantau event stop untuk service menggunakan fungsi WaitForStop. Keseluruhan rutin service ada pada procedure ServiceRun. Untuk menangkap argumen (install / uninstall) dan fungsional service melalui fungsi DoService.

{$APPTYPE CONSOLE}
program BeepSvc;

uses
  Windows,
  uService in 'uService.pas';

procedure ServiceRun;
begin
  while not WaitForStop(5 * 1000) do
    MessageBeep(MB_ICONASTERISK);
end;

begin
  DoService('Beeper', ServiceRun);
end.

Hasil kompilasi program di atas sangat kecil, hanya sekitar 18 KB. Bandingkan bila service tersebut menggunakan unit-unit yang tersedia di Delphi yang hasilnya 400-an KB.

Ketika program dijalankan dengan argumen ‘/?’ maka akan ditampilkan:

C:\dp\gtw\echo>beepsvc /?
Beeper usage help:
/I = Install manual startup
/U = Uninstall

Untuk menjalankan, mematikan dan mengganti parameter dari service dilakukan melalui Service Manager yang tersedia di Windows NT/2K/XP.

Demikian semoga bermanfaat. Salam.