Example. Daemon - JulTob/Ada GitHub Wiki
Daemon
Example by Petr Holub.
pragma License (GPL);
with Ada.Exceptions; use Ada.Exceptions; with Ada.Text_IO; use Ada.Text_IO; with Ada.Strings.Unbounded; use Ada.Strings.Unbounded; with Ada.Command_Line; use Ada.Command_Line;
with Sys_Interface; use Sys_Interface; with Sys_Interface.Daemon; use Sys_Interface.Daemon;
procedure Daemon is
begin Put_Line ("Starting Ada daemon"); Daemonize; Syslog (LOG_NOTICE, "Ada daemon runs as daemon now."); delay 120.0; Syslog (LOG_NOTICE, "Ada daemon terminates."); end Daemon;
-- Settings provides basic thin intefaces to POSIX/UN*X functions that are needed. For Configurator it supports Linux/FreeBSD only.
pragma License (GPL);
with Ada.Strings.Unbounded; use Ada.Strings.Unbounded;
package Sys_Interface is
type OS_Type is (FreeBSD, Linux, Windows); Running_OS : OS_Type := FreeBSD;
-- errno : Integer; -- pragma Import (C, errno); -- XXX: doesn't work on Linux properly; why? how to do it? GNAT.Os_Lib?
procedure Perror (Descr : String);
procedure System (Command : String; Return_Val : out Integer; Signal : out Integer); function System (Command : String) return Integer; procedure System (Command : in String);
type Log_Prioriry_Type is (LOG_EMERG, LOG_ALERT, LOG_CRIT, LOG_ERR, LOG_WARNING, LOG_NOTICE, LOG_INFO, LOG_DEBUG); procedure Syslog (Log_Priority : in Log_Prioriry_Type; Text : in String);
type pid_t is new Integer; function Fork return pid_t; procedure SetPGID (PID : pid_t; PGRP : pid_t); function GetPID return pid_t; procedure Wait (PID : out pid_t; Status : out Integer); procedure Wait_Pid (PID : out pid_t; PID_or_GID : in pid_t; Status : out Integer; Options : Integer);
type Signal_Type is (SIGHUP, SIGINT, SIGQUIT, SIGKILL, SIGPIPE, SIGALRM, SIGTERM, SIGSTOP, SIGTSTP, SIGCONT, SIGINFO, SIGUSR1, SIGUSR2); function Kill (PID : pid_t; Signal : Signal_Type) return Integer; function Kill_PG (PID : pid_t; Signal : Signal_Type) return Integer;
private
for Log_Prioriry_Type use (LOG_EMERG => 0, LOG_ALERT => 1, LOG_CRIT => 2, LOG_ERR => 3, LOG_WARNING => 4, LOG_NOTICE => 5, LOG_INFO => 6, LOG_DEBUG => 7); for Log_Prioriry_Type'Size use Integer'Size;
for Signal_Type use (SIGHUP => 1, SIGINT => 2, SIGQUIT => 3, SIGKILL => 9, SIGPIPE => 13, SIGALRM => 14, SIGTERM => 15, SIGSTOP => 17, SIGTSTP => 18, SIGCONT => 19, SIGINFO => 29, SIGUSR1 => 30, SIGUSR2 =7gt; 31); for Signal_Type'Size use Integer'Size;
end Sys_Interface;
with Ada.Unchecked_Conversion; with Interfaces.C.Strings; use Interfaces.C.Strings; with Interfaces.C; use Interfaces.C; with Interfaces; use Interfaces; with Interfaces.C_Streams; use Interfaces.C_Streams;
package body Sys_Interface is
-- Imports of system functions
procedure C_perror (descr : chars_ptr); pragma Import (C, C_perror, "perror");
function C_system (command : chars_ptr) return Integer; pragma Import (C, C_system, "system");
procedure C_syslog (Log_Priority : in Integer; Format : in chars_ptr; Text : in chars_ptr); pragma Import (C, C_syslog, "syslog");
function C_fork return pid_t; pragma Import (C, C_fork, "fork");
procedure C_wait (pid : out pid_t; status : out Integer); pragma Import (C, C_wait, "wait"); pragma Import_Valued_Procedure (C_wait);
procedure C_waitpid (pid : out pid_t; pid_or_gid : in pid_t; status : out Integer; options : Integer); pragma Import (C, C_waitpid, "waitpid"); pragma Import_Valued_Procedure (C_waitpid);
procedure C_getpid (PID : out pid_t); pragma Import (C, C_getpid, "getpid"); pragma Import_Valued_Procedure (C_getpid);
function C_kill (PID : pid_t; Signal : Integer) return Integer; pragma Import (C, C_kill, "kill");
function C_killpg (PID : pid_t; Signal : Integer) return Integer; pragma Import (C, C_killpg, "killpg");
procedure C_setpgid (PID : pid_t; PGRP : pid_t); pragma Import (C, C_setpgid, "setpgid");
-- Sysinterface body
function LPT_To_Int is new Ada.Unchecked_Conversion (Source => Log_Prioriry_Type, Target => Integer);
function Signal_Type_To_Int is new Ada.Unchecked_Conversion (Source => Signal_Type, Target => Integer);
procedure Perror (Descr : in String) is C_descr : chars_ptr; begin C_descr := New_String (Descr); C_perror (C_descr); Free (C_descr); end Perror;
procedure System (Command : String; Return_Val : out Integer; Signal : out Integer) is C_command : chars_ptr; C_Ret_Val : Integer; begin C_command := New_String (Command); C_Ret_Val := C_system (C_command); Return_Val := Integer (Shift_Right (Unsigned_32 (C_Ret_Val), 8)); -- Return_Val = -1 .... fork or waitpid failed -- Return_Val = 127 ... missing binary to be executed Signal := Integer (Unsigned_32 (C_Ret_Val) and 255); Free (C_command); return; end System;
function System (Command : String) return Integer is Ret_Val : Integer; Signal : Integer; begin System (Command, Ret_Val, Signal); return Ret_Val; end System;
procedure System (Command : in String) is Ret_Val : Integer; begin Ret_Val := System (Command); pragma Unreferenced (Ret_Val); end System;
procedure Syslog (Log_Priority : in Log_Prioriry_Type; Text : in String) is Format_String : constant String := "%s"; C_Format : chars_ptr; C_Text : chars_ptr; begin C_Format := New_String (Format_String); C_Text := New_String (Text); C_syslog (LPT_To_Int (Log_Priority), C_Format, C_Text); Free (C_Format); Free (C_Text); end Syslog;
function Fork return pid_t is begin return C_fork; end Fork;
procedure SetPGID (PID : pid_t; PGRP : pid_t) is begin C_setpgid (PID, PGRP); end SetPGID;
procedure Wait (PID : out pid_t; Status : out Integer) is begin C_wait (PID, Status); end Wait;
procedure Wait_Pid (PID : out pid_t; PID_or_GID : in pid_t; Status : out Integer; Options : Integer) is begin C_waitpid (PID, PID_or_GID, Status, Options); end Wait_Pid;
function GetPID return pid_t is PID : pid_t; begin C_getpid (PID); return PID; end GetPID;
function Kill (PID : pid_t; Signal : Signal_Type) return Integer is begin return C_kill (PID, Signal_Type_To_Int (Signal)); end Kill;
function Kill_PG (PID : pid_t; Signal : Signal_Type) return Integer is begin return C_killpg (PID, Signal_Type_To_Int (Signal)); end Kill_PG;
function C_popen (Command, Mode : String) return FILEs; pragma Import (C, C_popen, "popen");
procedure C_pclose (Result : out Integer; FID : FILEs); pragma Import (C, C_pclose, "pclose"); pragma Import_Valued_Procedure (C_pclose);
end Sys_Interface; pragma License (GPL);
package Sys_Interface.Daemon is
procedure Daemonize;
end Sys_Interface.Daemon;
package body Sys_Interface.Daemon is
procedure C_daemonize; pragma Import (C, C_daemonize, "daemonize");
procedure Daemonize is begin C_daemonize; end Daemonize;
end Sys_Interface.Daemon;
#include #include #include
void daemonize(void) { int i,n = getdtablesize();
if (chdir("/")) { perror("chdir to /"); exit(EXIT_FAILURE); } for (i=0; i<n; i++) (void) close(i);
switch (fork()) {
case -1:
perror("daemonize fork");
exit(EXIT_FAILURE);
case 0:
if(setsid() == -1) {
perror("setsid");
exit(EXIT_FAILURE);
}
break;
default:
exit(EXIT_SUCCESS);
}
}