Assa's Service Unit - FPC mag es nicht

[gbl]

Ic passe gerade Assarbat's Unit SERVICE an, damit FPC / Lazarus diese übersetzen kann.

Bei folgendem Code hab' ich keinen Plan wieso der Compiler streikt.

Delphi-Quellcode:

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]);     // << Hier entsteht der Fehler
END;

service.pas(168,46) Error: Incompatible type for arg no. 1: Got "_SERVICE_TABLE_ENTRYA", expected "LPSERVICE_TABLE_ENTRYA"
g3svc.lpr(3709,10) Hint: Found declaration: StartServiceCtrlDispatcher(LPSERVICE_TABLE_ENTRYA) :LongBool;StdCall
service.pas(212,66) Error: Identifier not found "_DELETE"

Kann mir da jemand weiterhelfen?

[Olli]

Das ist nur, weil FPC mich nicht mag. Es existiert inzwischen auch eine Haßliebe zwischen uns :mrgreen:

Hast du mal die Deklaration der Funktion StartServiceCtrlDispatcher() in FPC parat? ... ich denke daran könnte es liegen.

Auweia, die Unit bedarf auch mal wieder einer starken Überarbeitung :shock:

[gbl]

Ha, da war aber einer schnell ...

Delphi-Quellcode:

function StartServiceCtrlDispatcherA(lpServiceStartTable: LPSERVICE_TABLE_ENTRYA): BOOL; stdcall;

{$EXTERNALSYM StartServiceCtrlDispatcherA}

function StartServiceCtrlDispatcherW(lpServiceStartTable: LPSERVICE_TABLE_ENTRYW): BOOL; stdcall;

{$EXTERNALSYM StartServiceCtrlDispatcherW}

function StartServiceCtrlDispatcher(lpServiceStartTable: LPSERVICE_TABLE_ENTRY): BOOL; stdcall;

{$EXTERNALSYM StartServiceCtrlDispatcher}

[Olli]

Jupp, dann mach mal ein @ davor (vor den Parameter). Dann müßte es wohl gehen. Ist anders deklariert als in Delphi sonst ...

[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;

[Olli]

Aber es handelt sich schon um ein Konsolenprogramm?

[gbl]

Ja natürlich, im Hauptprogramm hab' ich noch einen Switch eingebaut, damit ich den eigendlichen Service besser testen kann.
Überflüssig zu erwähnen, daß es unter DELPHI problemlos funktionierte.

Delphi-Quellcode:

BEGIN
  r_g3.timedelta:=def_timedelta;
  time0:=Time;

  runshell:=(paramstr(1)='/applicationmode') or (paramstr(1)='/c');

  if runshell then
  begin
//    ClrScr;
//    FlushInputBuffer;
    writeln('Running in Application Mode');
    writeln;

//    SERVICE_MAIN
  end
  else
    PROG_MAIN;
END.

[gbl]

Ich hab's gefunden.

Ich habe das Projekt aus Delphi importiert.
Im unterschied zu Delphi kennt FPC/Lazarus die Direktive {$APP CONSOLE} nicht. Diese Einstellung ist mit einem Compilerschalter vorzunehmen.

[Olli]

Zitat:

Zitat von gbl

Im unterschied zu Delphi kennt FPC/Lazarus die Direktive {$APP CONSOLE} nicht. Diese Einstellung ist mit einem Compilerschalter vorzunehmen.

Probier mal {$APPTYPE CONSOLE} ... APP kenne ich noch garnicht :mrgreen: ... geht's dann? Oder hilft der Delphi-Kompatibilitätsmodus vielleicht?

[gbl]

Achja, $APPTYPE hats geheisen ::)
Im übrigen wollte ich den Kompatibilitätsmodus bewust nich verwenden. Delphi ist das etwas lax mit den Typenumwandlungen. z.B. ist es kein Problem ein DWORD einem INT Datentyp zuzuweisen. FPC regt sich da erstmal kräftig auf. Ich glaube das tut den Entwicklern und der Qualität der Software ganz gut.

Darum poste ich jetzt gar nicht.

Ich dmöchte nun offiziell verkünden daß die von mir modifizierte service.inc korrekt von Lazarus übersetzt wird!
Der Feldtest mit Service installieren / deinstallieren hat ohne BSOD :() funktioniert.

Die Datei consolehelp.inc ist in diesem Fall momentan nicht nötig (wenn man keine Farben benötigt).

Also:
ich schreib' meine Software erstmal unter Lazarus weiter. Kommt in späterer Folge billiger.