{

TODO:

}

unit Unit1;

{$mode objfpc}{$H+}

interface

uses

Classes, SysUtils, FileUtil, Forms, Controls, Graphics, Dialogs, ExtCtrls,

StdCtrls, Menus, Buttons, SynMemo;

const

APP_NAME = 'BEER Media Server';

SHORT_APP_NAME = 'BMS';

APP_VERSION = '2.0.130525';

SHORT_APP_VERSION = '2.0';

type

{ TForm1 }

TForm1 = class(TForm)

BitBtn1: TBitBtn;

BitBtn2: TBitBtn;

CheckBoxLog: TCheckBox;

MemoLog: TSynMemo;

procedure BitBtn2Click(Sender: TObject);

procedure CheckBoxLogChange(Sender: TObject);

procedure FormCreate(Sender: TObject);

private

{ private declarations }

procedure AsyncFromCreate({%H-}Data: PtrInt);

public

{ public declarations }

end;

var

Form1: TForm1;

TrayIcon: TTrayIcon;

procedure InitAfterApplicationInitialize;

implementation

uses

LCLIntf, blcksock, synsock, synautil,

DOM, XMLWrite, XMLRead, MediaInfoDll,

//Lua, lualib, lauxlib,

lua52,

{$IFDEF Windows}

interfacebase, win32int, windows, // for Hook SUSPEND EVENT

{$ENDIF}

lazutf8classes, inifiles, comobj, contnrs, process, SynRegExpr,

dateutils, simpleipc,

unit2;

{$R *.lfm}

const

HTTP_HEAD_SERVER = 'OS/1.0, UPnP/1.0, ' + SHORT_APP_NAME + '/' + SHORT_APP_VERSION;

INI_SEC_SYSTEM = 'SYSTEM';

INI_SEC_MIKeys = 'MInfoKeys';

INI_SEC_SCRIPTS = 'SCRIPTS';

MEDIA_INFO_DB_FILENAME = 'mi.db';

MEDIA_INFO_DB_HEADER = 'midb01';

MAX_ONMEM_LOG = 500;

type

{ TMyApp }

TMyApp = class

public

Log: TStringListUTF8;

LogFile: TFileStreamUTF8;

PopupMenu: TPopupMenu;

constructor Create;

destructor Destroy; override;

procedure OnTrayIconClick(Sender: TObject);

procedure OnMenuShowClick(Sender: TObject);

procedure OnMenuQuitClick(Sender: TObject);

procedure AddLog(const line: string);

procedure WMPowerBoadcast(var msg: TMessage);

end;

{ THttpDaemon }

THttpDaemon = class(TThread)

private

Sock: TTCPBlockSocket;

line: string;

th_list: TObjectList;

procedure AddLog;

public

SendAliveFlag: boolean;

constructor Create;

destructor Destroy; override;

procedure Execute; override;

end;

{ THttpThrd }

TClientInfo = class;

THttpThrd = class(TThread)

private

Sock: TTCPBlockSocket;

line: string;

L_S: Plua_State;

ClientInfo: TClientInfo;

procedure AddLog;

function DoPlay(sno: integer; const fname, request: string): boolean;

function DoPlayTranscode(sno: integer; const fname, request: string): boolean;

function DoBrowse(docr, docw: TXMLDocument): boolean;

function SendRaw(buf: Pointer; len: integer): boolean; overload;

function SendRaw(const buf: string): boolean; overload;

public

Done: boolean;

Headers: TStringListUTF8;

InputData, OutputData: TMemoryStream;

UniOutput: boolean;

InHeader: string;

constructor Create(hSock: TSocket);

destructor Destroy; override;

procedure Execute; override;

function ProcessHttpRequest(const Request, URI: string): integer;

end;

{ TSSDPDaemon }

TSSDPDaemon = class(TThread)

private

Sock: TUDPBlockSocket;

line: string;

procedure AddLog;

public

constructor Create;

destructor Destroy; override;

procedure Execute; override;

end;

{ TGetMediaInfo }

TGetMediaInfo = class(TValStringList)

private

public

FileName, AccTime: string;

FileSize: Int64;

IsTemp: boolean;

PlayInfo: TStringList;

constructor Create(const fname: string; mi: Cardinal; ExKeys: TStringList);

destructor Destroy; override;

procedure GetPlayInfo(L: PLua_State; get_new: boolean = False);

procedure SaveToStream(Stream: TStream); override;

procedure LoadFromStream(Stream: TStream); override;

end;

{ TMediaInfoCollector }

TMediaInfoCollector = class(TThread)

private

miHandle: Cardinal;

mi_list, mi_ac_list, exkey_list: TStringListUTF8;

MaxMediaInfo: integer;

public

cs_list, cs_ac_list, cs_pr_list, cs_get_mi: TCriticalSection;

PriorityList: TStringListUTF8;

constructor Create;

destructor Destroy; override;

procedure Execute; override;

function GetMediaInfo(const fname: string): TGetMediaInfo;

procedure AddExKey(const key: string);

procedure ClearMediaInfo;

procedure LoadMediaInfo;

procedure SaveMediaInfo;

end;

{ TClientInfo }

TClientInfo = class

private

public

L_S: Plua_State;

CurId, CurDir: string;

chunks: TStringList;

FullInfoCount: integer;

CurFileList: TStringList;

LastAccTime: TDateTime;

ScriptFileName: string;

SortType: integer;

InfoTable: TValStringList;

constructor Create;

destructor Destroy; override;

end;

{ TChunkObj }

TChunkObj = class

bin: string;

time: integer;

end;

{ TMySimpleIPCServer }

TMySimpleIPCServer = class(TSimpleIPCServer)

private

cs_vsl: TCriticalSection;

vsl: TValStringList;

procedure DoMessage(Sender: TObject);

public

constructor {%H-}Create;

destructor Destroy; override;

function GetValue(const vname: string): string;

procedure SetValue(const vname, val: string);

end;

var

iniFile: TIniFile;

ExecPath, TempPath, UUID, DAEMON_PORT: string;

MAX_REQUEST_COUNT, SEND_DATA_TIMEOUT: integer;

MyApp: TMyApp;

thHttpDaemon: THttpDaemon;

thSSDPDAemon: TSSDPDaemon;

thMIC: TMediaInfoCollector;

SIPCServer: TMySimpleIPCServer;

MediaDirs: TStringList;

ClientInfoList: TStringList;

MyIPAddr: string;

function Alloc({%H-}ud, ptr: Pointer; {%H-}osize, nsize: size_t) : Pointer; cdecl;

begin

try

Result:= ptr;

ReallocMem(Result, nSize);

except

Result:= nil;

end;

end;

function print_func(L : Plua_State) : Integer; cdecl;

var

i, c: integer;

s: string;

begin

Result := 0;

if not Assigned(MyApp) then Exit;

c:= lua_gettop(L);

s:= '';

for i:= 1 to c do s:= s + lua_tostring(L, i);

MyApp.AddLog(s);

end;

function tonumberDef_func(L : Plua_State) : Integer; cdecl;

var

s: string;

n: lua_Number;

begin

s:= lua_tostring(L, 1);

n:= lua_tonumber(L, 2);

lua_pushnumber(L, StrToFloatDef(s, n));

Result := 1;

end;

function regexpr_matches_func(L : Plua_State) : Integer; cdecl;

var

s1, s2: string;

begin

s1:= lua_tostring(L, 1);

s2:= lua_tostring(L, 2);

try

lua_pushboolean(L, ExecRegExpr(s2, s1));

except

on E: Exception do begin

luaL_error(L, PChar(E.Message), []);

end;

end;

Result := 1;

end;

function ScriptFileExists_func(L : Plua_State) : Integer; cdecl;

var

s, s1, s2: string;

b: boolean;

begin

s:= lua_tostring(L, 1);

b:= FileExistsUTF8(ExecPath + 'script/' + s + '.lua');

if not b then begin

s1:= SIPCServer.GetValue('UserScripts');

while not b do begin

s2:= Fetch(s1, '|');

if s2 = '' then Break;

b:= FileExistsUTF8(ExecPath + 'script/' + s2 + '/' + s + '.lua');

end;

end;

lua_pushboolean(L, b);

Result := 1;

end;

function ExtractFileName_func(L : Plua_State) : Integer; cdecl;

begin

lua_pushstring(L, ExtractFileName(lua_tostring(L, 1)));

Result := 1;

end;

function ExtractFilePath_func(L : Plua_State) : Integer; cdecl;

begin

lua_pushstring(L, ExtractFilePath(lua_tostring(L, 1)));

Result := 1;

end;

function GetCmdStdOut_func(L : Plua_State) : Integer; cdecl;

var

s: string;

proc: TPipeProcExec;

begin

proc:= TPipeProcExec.Create;

try

s:= lua_tostring(L, 1);

{$IFDEF Windows}

if ExtractFilePath(s) = '' then s:= ExecPath + s;

{$ENDIF}

proc.Cmds.Add('"' + s + '" ' + lua_tostring(L, 2));

proc.Start;

while not proc.Done do ;

lua_pushstring(L, proc.OutputMsgs[0]);

Result := 1;

finally

//proc.Terminate;

//proc.WaitFor;

proc.Free;

end;

end;

function FileExists_func(L : Plua_State) : Integer; cdecl;

begin

lua_pushboolean(L, FileExistsUTF8(lua_tostring(L, 1)));

Result := 1;

end;

(*

function GetTempFileName_func(L : Plua_State) : Integer; cdecl;

begin

lua_pushstring(L, FileUtil.GetTempFileName(lua_tostring(L, 1), lua_tostring(L, 2)));

Result := 1;

end;

function DeleteFileMatches_func(L : Plua_State) : Integer; cdecl;

var

info: TSearchRec;

dir, reg: string;

begin

Result := 0;

dir:= lua_tostring(L, 1);

reg:= lua_tostring(L, 2);

if dir = '' then Exit;

if FindFirstUTF8(dir+'*', faAnyFile, info) = 0 then

try

repeat

if (info.Name <> '.') and (info.Name <> '..') and

ExecRegExpr(reg, info.Name) then begin

if info.Attr and faDirectory <> 0 then begin

//RemoveDirPerfect(dir+info.Name+'/');

end else begin

DeleteFileUTF8(dir + info.Name);

end;

end;

until FindNextUTF8(info) <> 0;

finally

FindCloseUTF8(Info);

end;

end;

*)

procedure InitLua(L: Plua_State);

procedure regTable(const tablename, funcname: string; func: lua_CFunction);

begin

lua_getglobal(L, PChar(tablename));

if lua_isnil(L, -1) then begin

lua_pop(L, 1);

lua_newtable(L);

lua_setglobal(L, PChar(tablename));

lua_getglobal(L, PChar(tablename));

end;

lua_pushstring(L, funcname);

lua_pushcfunction(L, func);

lua_settable(L, -3);

lua_setglobal(L, PChar(tablename));

end;

begin

luaL_openlibs(L);

lua_register(L, 'print', @print_func);

lua_register(L, 'tonumberDef', @tonumberDef_func);

regTable('fileu', 'ExtractFileName', @ExtractFileName_func);

regTable('fileu', 'ExtractFilePath', @ExtractFilePath_func);

regTable('fileu', 'GetCmdStdOut', @GetCmdStdOut_func);

regTable('fileu', 'FileExists', @FileExists_func);

//regTable('fileu', 'GetTempFileName', @GetTempFileName_func);

//regTable('fileu', 'DeleteFileMatches', @DeleteFileMatches_func);

regTable('regexpr', 'matches', @regexpr_matches_func);

lua_register(L, 'BMS_ScriptFileExists', @ScriptFileExists_func);

lua_pushstring(L, ExecPath); lua_setglobal(L, 'BMS_ExecPath');

lua_pushstring(L, TempPath); lua_setglobal(L, 'BMS_TempPath');

lua_getglobal(L, 'package');

lua_pushstring(L, 'path');

lua_pushstring(L, ExecPath + 'script' + DirectorySeparator + '?.lua');

lua_settable(L, -3);

lua_pushstring(L, 'cpath');

lua_pushstring(L, ExecPath + 'script' + DirectorySeparator + '?.dll');

lua_settable(L, -3);

lua_pop(L, 1);

end;

procedure CallLua(L: Plua_State; nargs, nresults: Integer);

begin

if lua_pcall(L, nargs, nresults, 0) <> 0 then

Raise Exception.Create('Lua Runtime Error('+lua_tostring(L, -1)+')');

end;

function DumpWriter({%H-}L: Plua_State; const p: Pointer; sz: size_t;

ud: Pointer): Integer; cdecl;

var

DumpSize: LongWord;

begin

DumpSize:= PLongWord(ud^)^;

PLongWord(ud^)^:= DumpSize + sz;

ReallocMem(PChar(ud^), SizeOf(LongWord)+DumpSize+sz);

move(Byte(p^), (PChar(ud^)+SizeOf(LongWord)+DumpSize)^, sz);

Result:= 0;

end;

function LoadLuaRawRaw(L: Plua_State; const code, module: string; GetBin: boolean): string;

var

DumpCode: PChar;

begin

Result:= '';

if luaL_loadbuffer(L, PChar(code), Length(code), PChar(module)) <> 0 then

Raise Exception.Create(module + ' Compile Error(' + lua_tostring(L, -1)+')');

if GetBin then begin

// コンパイル済みコードを保持

GetMem(DumpCode, SizeOf(LongWord));

try

PLongWord(DumpCode)^:= 0;

lua_dump(L, @DumpWriter, @DumpCode);

SetLength(Result, PLongWord(DumpCode)^);

move((DumpCode+SizeOf(LongWord))^, Result[1], PLongWord(DumpCode)^);

finally

FreeMem(DumpCode);

end;

end;

CallLua(L, 0, 0);

end;

function LoadLuaRaw(L: Plua_State; const fname: string;

const code: string = ''; code_t: integer = 0): string;

var

sl: TStringListUTF8;

begin

if fname = '' then Exit;

if (code <> '') and (GetFileTime(fname) = code_t) then begin

LoadLuaRawRaw(L, code, fname + '.lua', False);

Result:= '';

end else begin

sl:= TStringListUTF8.Create;

try

try

sl.LoadFromFile(fname);

except

Exit;

end;

if (sl.Count > 0) and (Length(sl[0]) >= 3) and

(sl[0][1] = #$EF) and (sl[0][2] = #$BB) and (sl[0][3] = #$BF) then begin

// BOM を削除

sl[0]:= Copy(sl[0], 4, MaxInt);

end;

Result:= LoadLuaRawRaw(L, sl.Text, fname, True);

finally

sl.Free;

end;

end;

end;

procedure LoadLua(L: Plua_State; const fname: string; chunks: TStringList);

var

s, s1, s2, chunk: string;

i: Integer;

obj: TChunkObj;

begin

if fname = '' then Exit;

if ExtractFilePath(fname) = '' then begin

s:= ExecPath + 'script/' + fname + '.lua';

if FileExistsUTF8(s) then begin

i:= chunks.IndexOf(fname);

if i < 0 then begin

obj:= TChunkObj.Create;

chunks.AddObject(fname, obj);

end else

obj:= TChunkObj(chunks.Objects[i]);

chunk:= LoadLuaRaw(L, s, obj.bin, obj.time);

if chunk <> '' then begin

obj.bin:= chunk;

obj.time:= GetFileTime(s);

end;

end;

s1:= SIPCServer.GetValue('UserScripts');

while True do begin

s2:= Fetch(s1, '|');

if s2 = '' then Break;

s:= ExecPath + 'script/' + s2 + '/' + fname + '.lua';

if not FileExistsUTF8(s) then Continue;

i:= chunks.IndexOf(s2 + '/' + fname);

if i < 0 then begin

obj:= TChunkObj.Create;

chunks.AddObject(s2 + '/' + fname, obj);

end else

obj:= TChunkObj(chunks.Objects[i]);

chunk:= LoadLuaRaw(L, s, obj.bin, obj.time);

if chunk <> '' then begin

obj.bin:= chunk;

obj.time:= GetFileTime(s);

end;

end;

end else

LoadLuaRaw(L, fname);

end;

procedure MIValue2LuaTable(L: PLua_State; const key, val: string);

var

s, ss: string;

isnill: boolean;

begin

s:= key;

ss:= Fetch(s, ';');

if s = '' then begin

lua_pushstring(L, ss);

lua_pushstring(L, val);

lua_rawset(L, -3);

end else begin

lua_pushstring(L, ss);

lua_rawget(L, -2);

isnill:= lua_isnil(L, -1);

if isnill then begin

lua_pop(L, 1);

lua_pushstring(L, ss);

lua_newtable(L);

end;

MIValue2LuaTable(L, s, val);

if isnill then begin

lua_rawset(L, -3);

end else begin

lua_pop(L, 1);

end;

end;

end;

procedure LuaTable2ValStringList(L: PLua_State; sl: TValStringList);

begin

lua_pushnil(L); // first key

while lua_next(L, -2) <> 0 do begin

// uses 'key' (at index -2) and 'value' (at index -1)

sl.AddVal(lua_tostring(L, -2), lua_tostring(L, -1));

// removes 'value'; keeps 'key' for next iteration

lua_pop(L, 1);

end;

end;

procedure ValStringList2LuaTable(L: PLua_State; sl: TValStringList);

var

i: integer;

begin

for i:= 0 to sl.Count-1 do begin

lua_pushstring(L, sl[i]);

lua_pushstring(L, sl.Vali[i]);

lua_rawset(L, -3);

end;

end;

procedure SendAlive;

var

sock: TUDPBlockSocket;

s: string;

begin

// Sends an advertisement "alive" message on multicast

sock:= TUDPBlockSocket.Create;

try

sock.Family:= SF_IP4;

sock.CreateSocket();

sock.Bind(MyIPAddr{'0.0.0.0'}, '0');

sock.MulticastTTL:= 1;

sock.Connect('239.255.255.250', '1900'{SSDP});

if sock.LastError = 0 then begin

//{

s:=

'NOTIFY * HTTP/1.1' + CRLF +

'HOST: 239.255.255.250:1900'+ CRLF +

'CACHE-CONTROL: max-age=1800'+ CRLF +

'LOCATION: http://' + MyIPAddr + ':' + DAEMON_PORT +

'/desc.xml' + CRLF +

'NT: upnp:rootdevice'+ CRLF +

'NTS: ssdp:alive'+ CRLF +

'SERVER: ' + HTTP_HEAD_SERVER + CRLF +

'USN: uuid:' + UUID + '::upnp:rootdevice' +

CRLF + CRLF;

sock.SendString(s);

s:=

'NOTIFY * HTTP/1.1' + CRLF +

'HOST: 239.255.255.250:1900'+ CRLF +

'CACHE-CONTROL: max-age=1800'+ CRLF +

'LOCATION: http://' + MyIPAddr + ':' + DAEMON_PORT +

'/desc.xml' + CRLF +

'NT: uuid:' + UUID + CRLF +

'NTS: ssdp:alive'+ CRLF +

'SERVER: ' + HTTP_HEAD_SERVER + CRLF +

'USN: uuid:' + UUID +

CRLF + CRLF;

sock.SendString(s);

//}

s:=

'NOTIFY * HTTP/1.1' + CRLF +

'HOST: 239.255.255.250:1900'+ CRLF +

'CACHE-CONTROL: max-age=1800'+ CRLF +

'LOCATION: http://' + MyIPAddr + ':' + DAEMON_PORT +

'/desc.xml' + CRLF +

'NT: urn:schemas-upnp-org:device:MediaServer:1' + CRLF +

'NTS: ssdp:alive'+ CRLF +

'SERVER: ' + HTTP_HEAD_SERVER + CRLF +

'USN: uuid:' + UUID + '::urn:schemas-upnp-org:device:MediaServer:1' +

CRLF + CRLF;

sock.SendString(s);

//{

s:=

'NOTIFY * HTTP/1.1' + CRLF +

'HOST: 239.255.255.250:1900'+ CRLF +

'CACHE-CONTROL: max-age=1800'+ CRLF +

'LOCATION: http://' + MyIPAddr + ':' + DAEMON_PORT +

'/desc.xml' + CRLF +

'NT: urn:schemas-upnp-org:service:ContentDirectory:1' + CRLF +

'NTS: ssdp:alive'+ CRLF +

'SERVER: ' + HTTP_HEAD_SERVER + CRLF +

'USN: uuid:' + UUID + '::urn:schemas-upnp-org:service:ContentDirectory:1' +

CRLF + CRLF;

sock.SendString(s);

s:=

'NOTIFY * HTTP/1.1' + CRLF +

'HOST: 239.255.255.250:1900'+ CRLF +

'CACHE-CONTROL: max-age=1800'+ CRLF +

'LOCATION: http://' + MyIPAddr + ':' + DAEMON_PORT +

'/desc.xml' + CRLF +

'NT: urn:schemas-upnp-org:service:ConnectionManager:1' + CRLF +

'NTS: ssdp:alive'+ CRLF +

'SERVER: ' + HTTP_HEAD_SERVER + CRLF +

'USN: uuid:' + UUID + '::urn:schemas-upnp-org:service:ConnectionManager:1' +

CRLF + CRLF;

sock.SendString(s);

//}

end;

finally

sock.Free;

end;

end;

procedure SendByebye;

var

sock: TUDPBlockSocket;

s: string;

begin

// Sends an advertisement "byebye" message on multicast

sock:= TUDPBlockSocket.Create;

try

Sock.Family:= SF_IP4;

sock.CreateSocket();

sock.Bind(MyIPAddr{'0.0.0.0'}, '0');

sock.MulticastTTL:= 1;

sock.Connect('239.255.255.250', '1900'{SSDP});

if sock.LastError = 0 then begin

//{

s:=

'NOTIFY * HTTP/1.1' + CRLF +

'HOST: 239.255.255.250:1900'+ CRLF +

'NT: upnp:rootdevice'+ CRLF +

'NTS: ssdp:byebye'+ CRLF +

'USN: uuid:' + UUID + '::upnp:rootdevice' +

CRLF + CRLF;

sock.SendString(s);

//}

s:=

'NOTIFY * HTTP/1.1' + CRLF +

'HOST: 239.255.255.250:1900'+ CRLF +

'NT: urn:schemas-upnp-org:device:MediaServer:1' + CRLF +

'NTS: ssdp:byebye'+ CRLF +

'USN: uuid:' + UUID + '::urn:schemas-upnp-org:device:MediaServer:1' +

CRLF + CRLF;

sock.SendString(s);

//{

s:=

'NOTIFY * HTTP/1.1' + CRLF +

'HOST: 239.255.255.250:1900'+ CRLF +

'NT: urn:schemas-upnp-org:service:ContentDirectory:1' + CRLF +

'NTS: ssdp:byebye'+ CRLF +

'USN: uuid:' + UUID + '::urn:schemas-upnp-org:service:ContentDirectory:1' +

CRLF + CRLF;

sock.SendString(s);

s:=

'NOTIFY * HTTP/1.1' + CRLF +

'HOST: 239.255.255.250:1900'+ CRLF +

'NT: urn:schemas-upnp-org:service:ConnectionManager:1' + CRLF +

'NTS: ssdp:byebye'+ CRLF +

'USN: uuid:' + UUID + '::urn:schemas-upnp-org:service:ConnectionManager:1' +

CRLF + CRLF;

sock.SendString(s);

//}

end;

finally

sock.Free;

end;

end;

function GetLineHeader: string;

begin

Result:= '*** ' + FormatDateTime('mm/dd hh:nn:ss ', Now);

end;

var

PrevWndProc: WNDPROC;

{$IFDEF Windows}

function WndCallback(Ahwnd: HWND; uMsg: UINT; wParam: WParam; lParam: LParam):LRESULT; stdcall;

var

msg: TMessage;

begin

case uMsg of

WM_POWERBROADCAST: begin

msg.Result:= Windows.DefWindowProc(Ahwnd, uMsg, WParam, LParam); //not sure about this one

msg.msg:= uMsg;

msg.wParam:= wParam;

msg.lParam:= lParam;

MyApp.WMPowerBoadcast(msg);

Result:= msg.Result;

Exit;

end;

WM_ENDSESSION: begin

SendByebye;

end;

end;

result:=CallWindowProc(PrevWndProc,Ahwnd, uMsg, WParam, LParam);

end;

{$ENDIF}

procedure InitAfterApplicationInitialize;

begin

{$IFDEF Windows}

PrevWndProc:= {%H-}Windows.WNDPROC(SetWindowLong(Widgetset.AppHandle, GWL_WNDPROC,{%H-}PtrInt(@WndCallback)));

{$ENDIF}

end;

{ TMyApp }

constructor TMyApp.Create;

var

mi: TMenuItem;

i: integer;

sl: TStringList;

sock: TBlockSocket;

s, tray_msg: String;

begin

tray_msg:= '';

UUID:= '';

if FileExistsUTF8(ExecPath + 'UUID') then begin

sl:= TStringListUTF8.Create;

try

sl.LoadFromFile(ExecPath + 'UUID');

if sl.Count > 0 then UUID:= sl[0];

finally

sl.Free;

end;

end;

if UUID = '' then begin

UUID:= Copy(CreateClassID, 2, 36); // 新しいUUIDを作成

sl:= TStringListUTF8.Create;

try

sl.Add(UUID);

sl.SaveToFile(ExecPath + 'UUID');

finally

sl.Free;

end;

end;

DAEMON_PORT:= iniFile.ReadString(INI_SEC_SYSTEM, 'HTTP_PORT', '5008');

Log:= TStringListUTF8.Create;

MAX_REQUEST_COUNT:= iniFile.ReadInteger(INI_SEC_SYSTEM, 'MAX_REQUEST_COUNT', 0);

SEND_DATA_TIMEOUT:= iniFile.ReadInteger(INI_SEC_SYSTEM, 'SEND_DATA_TIMEOUT', 60*60);

if SEND_DATA_TIMEOUT > 0 then SEND_DATA_TIMEOUT:= SEND_DATA_TIMEOUT * 1000

else SEND_DATA_TIMEOUT:= MaxInt;

MediaDirs:= TStringListUTF8.Create;

iniFile.ReadSectionValues('MediaDirs', MediaDirs);

i:= 0;

while i < MediaDirs.Count do begin

if (MediaDirs.Names[i] = '') or (MediaDirs.ValueFromIndex[i] = '') or

(Trim(MediaDirs[i])[1] = ';') then begin

MediaDirs.Delete(i);

end else

Inc(i);

end;

if MediaDirs.Count = 0 then

tray_msg:= tray_msg + CR + 'ERROR: bms.iniにおいて[MediaDirs]が未設定です。';

if not DirectoryExistsUTF8(TempPath) then

ForceDirectoriesUTF8(TempPath);

ClientInfoList:= TStringListUTF8_mod.Create;

ClientInfoList.Sorted:= True;

thMIC:= TMediaInfoCollector.Create;

try

thMIC.LoadMediaInfo;

except

tray_msg:= tray_msg + CR + 'ERROR: ' + MEDIA_INFO_DB_FILENAME + 'が破損しています。';

end;

sl:= TStringListUTF8.Create;

try

iniFile.ReadSections(sl);

if sl.IndexOf(INI_SEC_MIKeys) < 0 then

tray_msg:= tray_msg + CR + 'WARNING: bms.iniにおいて[' + INI_SEC_MIKeys + ']が未設定です。';

finally

sl.Free;

end;

thMIC.Start;

SIPCServer:= TMySimpleIPCServer.Create;

SIPCServer.ServerID:= 'SIPC:' + SHORT_APP_NAME + SHORT_APP_VERSION + ':' + DAEMON_PORT;

SIPCServer.vsl.Vals['UserScripts']:= iniFile.ReadString(INI_SEC_SCRIPTS, 'user', '');

SIPCServer.OnMessage:= @SIPCServer.DoMessage;

SIPCServer.Global:= True;

SIPCServer.StartServer;

sl:= TStringListUTF8.Create;

try

sock:= TBlockSocket.Create;

try

sock.Family:= SF_IP4;

sock.ResolveNameToIP(sock.LocalName, sl);

if sl.Count > 0 then begin

s:= iniFile.ReadString(INI_SEC_SYSTEM, 'IP_INTERFACE', '');

if s <> '' then begin

i:= StrToIntDef(s, 0);

if i > 0 then begin

if i <= sl.Count then

MyIPAddr:= sl[i-1];

end else if sl.IndexOf(s) >= 0 then

MyIPAddr:= s;

end;

if MyIPAddr = '' then

MyIPAddr:= sl[0];

end;

finally

sock.Free;

end;

finally

sl.Free;

end;

if MyIPAddr <> '' then begin

// Run HTTP Daemon

thHttpDaemon:= THttpDaemon.Create;

// Run SSDP Daemon

thSSDPDaemon:= TSSDPDaemon.Create;

//SendAlive;

end else begin

tray_msg:= tray_msg + CR + 'ERROR: 自己 IP アドレスが取得できませんでした。';

end;

PopupMenu:= TPopupMenu.Create(nil);

mi:= TMenuItem.Create(nil);

mi.Caption:= '&Show';

mi.OnClick:= @OnMenuShowClick;

PopupMenu.Items.Add(mi);

mi:= TMenuItem.Create(nil);

mi.Caption:= '-';

PopupMenu.Items.Add(mi);

mi:= TMenuItem.Create(nil);

mi.Caption:= '&Quit';

mi.OnClick:= @OnMenuQuitClick;

PopupMenu.Items.Add(mi);

TrayIcon.PopUpMenu := PopupMenu;

TrayIcon.OnClick:= @MyApp.OnTrayIconClick;

if tray_msg <> '' then begin

TrayIcon.BalloonHint:= tray_msg;

TrayIcon.ShowBalloonHint;

end;

end;

destructor TMyApp.Destroy;

var

i: Integer;

begin

SendByebye;

if Assigned(thSSDPDaemon) then begin

thSSDPDaemon.Terminate;

//thSSDPDaemon.Sock.CloseSocket;

thSSDPDaemon.WaitFor;

thSSDPDaemon.Free;

end;

if Assigned(thHttpDaemon) then begin

thHttpDaemon.Terminate;

//thHTTPDaemon.Sock.CloseSocket;

thHttpDaemon.WaitFor;

thHttpDaemon.Free;

end;

SIPCServer.Free;

if Assigned(thMIC) then begin

tHMIC.Suspended:= False;

thMIC.Terminate;

thMIC.WaitFor;

if iniFile.ReadInteger(INI_SEC_SYSTEM, 'SAVE_MEDIAINFO', 0) <> 0 then begin

try

thMIC.SaveMediaInfo;

except

end;

end else begin

DeleteFileUTF8(ExecPath + 'db/' + MEDIA_INFO_DB_FILENAME);

end;

thMIC.Free;

end;

for i:= 0 to ClientInfoList.Count-1 do ClientInfoList.Objects[i].Free;

ClientInfoList.Free;

Log.Free;

LogFile.Free;

MediaDirs.Free;

while PopupMenu.Items.Count > 0 do begin

PopupMenu.Items[0].Free;

//PopupMenu.Items.Delete(0);

end;

PopupMenu.Free;

inherited Destroy;

end;

procedure TMyApp.OnTrayIconClick(Sender: TObject);

begin

if Assigned(Form1) then begin

Form1.Show;

Form1.WindowState:= wsNormal;

end else begin

Application.CreateForm(TForm1, Form1);

try

//TrayIcon.PopupMenu.Items[1].Visible:= False;

if Form1.ShowModal = mrClose then begin

Application.Terminate;

Exit;

end;

//TrayIcon.PopupMenu.Items[1].Visible:= True;

finally

FreeAndNil(Form1);

end;

end;

end;

procedure TMyApp.OnMenuShowClick(Sender: TObject);

begin

OnTrayIconClick(nil);

end;

procedure TMyApp.OnMenuQuitClick(Sender: TObject);

begin

Application.Terminate;

end;

procedure TMyApp.AddLog(const line: string);

var

s: string;

begin

Log.Add(line);

while Log.Count > MAX_ONMEM_LOG do Log.Delete(0);