Assa's Service Unit - FPC mag es nicht

[gbl]

Danke,

auf die Idee bin ich nach dem POST auch gekommen. Einige Kleinigkeiten mußten noch angepasst werden, dann liß sich die UNIT kompilieren.
Ein interessantes Problem besteht noch darin, daß aus irgendeinem Grund das writeln überhaupt nicht funktioniert. d.H. entweder bekomme ich einen Dateizugriffsfehler, oder gar keine Reaktion.


Der Code erstmal:

Delphi-Quellcode:

(****************************************************************
 ****************************************************************
 ***                                                          ***
 ***        Copyright (c) 2001 by -=Assarbad [GoP]=-          ***
 ***       ____________                 ___________           ***
 ***      /\   ________\               /\   _____  \          ***
 ***     /  \  \       /    __________/  \  \    \  \         ***
 ***     \   \  \   __/___ /\   _____  \  \  \____\  \        ***
 ***      \   \  \ /\___  \  \  \    \  \  \   _______\       ***
 ***       \   \  \ /   \  \  \  \    \  \  \  \      /       ***
 ***        \   \  \_____\  \  \  \____\  \  \  \____/        ***
 ***         \   \___________\  \__________\  \__\            ***
 ***          \  /           /  /          /  /  /            ***
 ***           \/___________/ \/__________/ \/__/             ***
 ***                                                          ***
 ***  May the source be with you, stranger ... :-)            ***
 ***                                                          ***
 ***  Greets from -=Assarbad [GoP]=- ...                      ***
 ***  Special greets go 2 Nico, Casper, SA, Pizza, Navarion...***
 ***[for questions/proposals drop a mail to [email][e-mail][/email]]***
 *****************************************ASCII by Assa [GoP]****
 ****************************************************************)

(****************************************************************
 ***  modified for FPC / Lazarus                              ***
 ***  by gbl (Günter Wukoutz) in 08-2005                      ***
 ****************************************************************)
 
//include file for creating a service!

{$APPTYPE CONSOLE}
CONST
  cmd_install='Attempting to install "'+servicename+'" as a';
  cmd_installed='"%s" was successfully %sinstalled';
  press_anykey=#13#10#13#10+'Press any key to continue.';
  cmd_header=servicename+' - (c) 2005 by Guenter Wukoutz'+#13#10#13#10;
  cmd_syntax='Syntax : %s [/command+parameter]'#13#10#13#10+
    'Commands are single characters:'#13#10+
    'I'#9'Installs "'+servicename+'" as a service'#13#10+
    #9'Parameter:'#13#10+
    #9#9'A = Auto start, M = Manual start'#13#10+
    'U'#9'Uninstalls "'+servicename+'"'#13#10+
    press_anykey;

VAR
//  dispatchtable:ARRAY[0..1] OF tservicetableentry;
  sshstatushandle: service_status_handle;
  ssstatus: service_status;
  stopped: boolean;
  paused: boolean;
  param: STRING;
  currtextattr: word;
  modname: ARRAY[0..MAX_PATH-1] OF char;
  hSCM,
    hService: SC_HANDLE;
  startupmode: integer;

FUNCTION GetErrorMessage(code: Integer): STRING;
VAR
  hErrLib: DWORD;
  msg: PChar;
  flags: integer;

  FUNCTION MAKELANGID(p, s:word):Integer;
  BEGIN
    result:=(s SHL 10) OR p
  END;

BEGIN
  hErrLib:=LoadLibraryEx('NETMSG.DLL', 0, LOAD_LIBRARY_AS_DATAFILE);
  TRY
    flags:=FORMAT_MESSAGE_ALLOCATE_BUFFER OR
           FORMAT_MESSAGE_IGNORE_INSERTS OR
           FORMAT_MESSAGE_FROM_SYSTEM;
           
    CASE (hErrLib<>0) OF
      false:flags:=flags OR FORMAT_MESSAGE_FROM_HMODULE;
    END;
    
    IF FormatMessage(flags,
      pointer(hErrLib),
      code,
      integer((SUBLANG_NEUTRAL SHL 10)OR LANG_NEUTRAL),
      pchar(@msg),
      0,
      NIL)<>0
    THEN
      result:=STRING(msg);
      
    LocalFree(Integer(msg));
    
  FINALLY
    IF hErrLib<>0 THEN FreeLibrary(hErrLib)
  END
END;

PROCEDURE FatalError;
BEGIN
//  currtextattr:=textattribute;
//  settextattribute(FOREGROUND_RED OR FOREGROUND_INTENSITY);
  writeln('Error!');
//  settextattribute(currtextattr);
  writeln(Geterrormessage(getlasterror));
  halt;
END;

FUNCTION frmt(mformat:STRING; args:ARRAY OF POINTER): STRING;
VAR
  bla: pchar;
CONST
  Size=1024;
BEGIN
  getmem(bla, size);
  ZeroMemory(bla, size);
//  wvsprintf(bla, pchar(mformat), pchar(@args));
  result:=STRING(bla);
  freemem(bla, size);
END;

PROCEDURE servicehandler(fdwcontrol: DWORD); STDCALL;
BEGIN
  CASE fdwcontrol OF
    SERVICE_CONTROL_STOP:
      BEGIN
        stopped:=true;
        ssstatus.dwcurrentstate:=service_stop_pending;
        setservicestatus(sshstatushandle, ssstatus);
      END;
    SERVICE_CONTROL_PAUSE:
      BEGIN
        paused:=true;
        ssstatus.dwcurrentstate:=service_paused;
        setservicestatus(sshstatushandle, ssstatus);
      END;
    SERVICE_CONTROL_CONTINUE:
      BEGIN
        paused:=false;
        ssstatus.dwcurrentstate:=service_running;
        setservicestatus(sshstatushandle, ssstatus);
      END;
    SERVICE_CONTROL_INTERROGATE:
      setservicestatus(sshstatushandle, ssstatus);
    SERVICE_CONTROL_SHUTDOWN:
      stopped:=true;
  END;
END;

PROCEDURE serviceproc(dwargc: DWORD; lpszargv:pchar); STDCALL;   // var lpsz...
BEGIN
  sshstatushandle:=registerservicectrlhandler(pchar(servicename), @servicehandler);
  IF (sshstatushandle<>0) THEN BEGIN
    zeromemory(@ssstatus, sizeof(ssstatus));
    ssstatus.dwservicetype:=SERVICE_WIN32_OWN_PROCESS;
    ssstatus.dwcurrentstate:=SERVICE_START_PENDING;
    ssstatus.dwcontrolsaccepted:=SERVICE_ACCEPT_STOP OR SERVICE_ACCEPT_PAUSE_CONTINUE;
    ssstatus.dwwaithint:=1000;
    setservicestatus(sshstatushandle, ssstatus);
    stopped:=false;
    paused:=false;
    ssstatus.dwcurrentstate:=SERVICE_RUNNING;
    setservicestatus(sshstatushandle, ssstatus);
    SERVICE_MAIN;
    ssstatus.dwcurrentstate:=SERVICE_STOPPED;
    setservicestatus(sshstatushandle, ssstatus);
  END;

END;

PROCEDURE showsyntax;
BEGIN
  write(cmd_syntax);
//  write(frmt(cmd_syntax, [@modname[0]]));
//  readkey;
END;

PROCEDURE startasservice;
var dispatchtable:ARRAY[0..1] of tservicetableentry;
BEGIN
  dispatchtable[0].lpservicename:=pchar(servicename);
  dispatchtable[0].lpserviceproc:=@serviceproc;
  dispatchtable[1].lpservicename:=NIL;
  dispatchtable[1].lpserviceproc:=NIL;
  StartServiceCtrlDispatcher(@dispatchtable[0]);
END;

PROCEDURE PROG_MAIN;
BEGIN
  CASE paramcount OF
    0:startasservice;
  ELSE
  BEGIN
      GetModuleFileName(hInstance, @modname[0], MAX_PATH);
      Getlasterror;
      param:=paramstr(1);
      CASE param[1]='/' OF
        true:BEGIN
//            currtextattr:=textattribute;
//            settextattribute(FOREGROUND_GREEN OR FOREGROUND_INTENSITY);
            writeln(cmd_header);
//            settextattribute(currtextattr);
            CASE param[2] OF
              'I', 'i':BEGIN
//                  currtextattr:=textattribute;
//                  settextattribute(FOREGROUND_BLUE OR FOREGROUND_INTENSITY);
                  StartupMode:=SERVICE_DEMAND_START;
                  IF length(param)>2 THEN
                    CASE param[3] OF
                      'A', 'a':startupMode:=SERVICE_AUTO_START;
                    END
                    ELSE
                      StartupMode:=SERVICE_DEMAND_START;
                      
                  CASE startupMode OF
                    SERVICE_AUTO_START: writeln(cmd_install+'n autostart service');
                    SERVICE_DEMAND_START: writeln(cmd_install+' manual start service');
                  END;
                  
//                  settextattribute(currtextattr);
                  hSCM:=OpenSCManager(NIL, NIL, SC_MANAGER_ALL_ACCESS);
                  CASE hSCM OF
                    0:FatalError;
                  ELSE
                  BEGIN
                      hService:=CreateService(hSCM,
                        PChar(ServiceName),
                        PChar(DisplayName),
                        SERVICE_START OR SERVICE_QUERY_STATUS OR SERVICE_DELETE,
                        SERVICE_WIN32_OWN_PROCESS,// or SERVICE_INTERACTIVE_PROCESS,
                        StartupMode,
                        SERVICE_ERROR_NORMAL,
                        @modname[0],
                        NIL, NIL, NIL, NIL, NIL);
                      CASE hService OF
                        0:BEGIN
                            CloseServiceHandle(hSCM);
                            FatalError;
                          END;
                      ELSE
                      BEGIN
                          CloseServiceHandle(hSCM);
                          CloseServiceHandle(hService);
                          writeln(frmt(cmd_installed, [pchar(servicename), pchar('')]));
                        END;
                      END;
                    END;
                  END;
                END;
              'U', 'u':BEGIN
//                  currtextattr:=textattribute;
//                  settextattribute(FOREGROUND_BLUE OR FOREGROUND_INTENSITY);
                  writeln('Attempting to uninstall "'+servicename+'"');
//                  settextattribute(currtextattr);
                  hSCM:=OpenSCManager(NIL, NIL, SC_MANAGER_ALL_ACCESS);
                  CASE hSCM OF
                    0:FatalError;
                  ELSE
                  BEGIN
                      hService:=OpenService(hSCM, PChar(Servicename), SERVICE_ALL_ACCESS);
                      CASE hService OF
                        0:BEGIN
                            CloseServiceHandle(hSCM);
                            FatalError;
                          END;
                      ELSE
                      BEGIN
                          startupMode:=integer(DeleteService(hService));
                          CloseServiceHandle(hService);
                          CloseServiceHandle(hSCM);
                          CASE startupMode OF
                            0:FatalError;
                          ELSE
                            writeln(frmt(cmd_installed, [pchar(servicename), pchar('un')]));
                          END;//case
                        END;
                      END;//case
                    END;
                  END;//case
                END;
            ELSE
              showsyntax;
              
            END;//case
          END;
        false: startasservice;
      END;
    END;
  END;
END;