(****************************************************************
****************************************************************
*** ***
*** 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]Assarbad@ePost.de[/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;