From 40cc1d3731302747763023b0e46da73e395089ba Mon Sep 17 00:00:00 2001 From: michael Date: Fri, 29 Dec 2017 19:08:29 +0000 Subject: [PATCH] * Compile server git-svn-id: trunk@37874 - --- .gitattributes | 4 + utils/pas2js/compileserver.lpi | 66 ++++ utils/pas2js/compileserver.pp | 19 + utils/pas2js/dirwatch.pp | 624 +++++++++++++++++++++++++++++++++ utils/pas2js/fpmake.pp | 4 + utils/pas2js/httpcompiler.pp | 528 ++++++++++++++++++++++++++++ 6 files changed, 1245 insertions(+) create mode 100644 utils/pas2js/compileserver.lpi create mode 100644 utils/pas2js/compileserver.pp create mode 100644 utils/pas2js/dirwatch.pp create mode 100644 utils/pas2js/httpcompiler.pp diff --git a/.gitattributes b/.gitattributes index 1fef288b49..4ecd152889 100644 --- a/.gitattributes +++ b/.gitattributes @@ -16953,10 +16953,14 @@ utils/pas2jni/readme.txt svneol=native#text/plain utils/pas2jni/writer.pas svneol=native#text/plain utils/pas2js/Makefile svneol=native#text/plain utils/pas2js/Makefile.fpc svneol=native#text/plain +utils/pas2js/compileserver.lpi svneol=native#text/plain +utils/pas2js/compileserver.pp svneol=native#text/plain +utils/pas2js/dirwatch.pp svneol=native#text/plain utils/pas2js/dist/rtl.js svneol=native#text/plain utils/pas2js/docs/translation.html svneol=native#text/html utils/pas2js/fpmake.lpi svneol=native#text/plain utils/pas2js/fpmake.pp svneol=native#text/plain +utils/pas2js/httpcompiler.pp svneol=native#text/plain utils/pas2js/pas2js.cfg svneol=native#text/plain utils/pas2js/pas2js.lpi svneol=native#text/plain utils/pas2js/pas2js.pp svneol=native#text/plain diff --git a/utils/pas2js/compileserver.lpi b/utils/pas2js/compileserver.lpi new file mode 100644 index 0000000000..984cf4c256 --- /dev/null +++ b/utils/pas2js/compileserver.lpi @@ -0,0 +1,66 @@ + + + + + + + + + + + + + + <UseAppBundle Value="False"/> + <ResourceType Value="res"/> + </General> + <BuildModes Count="1"> + <Item1 Name="Default" Default="True"/> + </BuildModes> + <PublishOptions> + <Version Value="2"/> + </PublishOptions> + <RunParams> + <local> + <FormatVersion Value="1"/> + </local> + </RunParams> + <Units Count="3"> + <Unit0> + <Filename Value="compileserver.pp"/> + <IsPartOfProject Value="True"/> + </Unit0> + <Unit0> + <Filename Value="httpcompiler.pp"/> + <IsPartOfProject Value="True"/> + </Unit0> + <Unit1> + <Filename Value="dirwatch.pp"/> + <IsPartOfProject Value="True"/> + </Unit1> + </Units> + </ProjectOptions> + <CompilerOptions> + <Version Value="11"/> + <Target> + <Filename Value="compileserver"/> + </Target> + <SearchPaths> + <IncludeFiles Value="$(ProjOutDir)"/> + <UnitOutputDirectory Value="lib/$(TargetCPU)-$(TargetOS)"/> + </SearchPaths> + </CompilerOptions> + <Debugging> + <Exceptions Count="3"> + <Item1> + <Name Value="EAbort"/> + </Item1> + <Item2> + <Name Value="ECodetoolError"/> + </Item2> + <Item3> + <Name Value="EFOpenError"/> + </Item3> + </Exceptions> + </Debugging> +</CONFIG> diff --git a/utils/pas2js/compileserver.pp b/utils/pas2js/compileserver.pp new file mode 100644 index 0000000000..1f70a44a56 --- /dev/null +++ b/utils/pas2js/compileserver.pp @@ -0,0 +1,19 @@ +program compileserver; + +{$mode objfpc} +{$h+} + +uses + {$IFDEF UNIX}cthreads,{$ENDIF} httpcompiler; + + +Var + Application : THTTPCompilerApplication; + +begin + Application:=THTTPCompilerApplication.Create(Nil); + Application.Initialize; + Application.Run; + Application.Free; +end. + diff --git a/utils/pas2js/dirwatch.pp b/utils/pas2js/dirwatch.pp new file mode 100644 index 0000000000..3b3892acd4 --- /dev/null +++ b/utils/pas2js/dirwatch.pp @@ -0,0 +1,624 @@ +unit dirwatch; +{$IFDEF LINUX} +{$DEFINE USEINOTIFY} +{$ELSE} +{$DEFINE USEGENERIC} +{$ENDIF} + +{$mode objfpc}{$H+} + +interface + +uses + Classes, SysUtils, +{$IFDEF UNIX} + baseunix, +{$IFDEF USEINOTIFY} + ctypes, + linux, +{$ENDIF} +{$ENDIF} + contnrs; + + + +Type + TFileEvent = (feModify,feAttrib,feCreate,feDelete); + TFileEvents = set of TFileEvent; + + { TDirectoryEntry } + TDirectoryEntry = Class(TCollectionItem) + private + FEvents: TFileEvents; + FName: String; + FAttributes: Integer; +{$IFDEF UNIX} + FGroup: gid_t; + FMode: mode_t; + FOwner: uid_t; +{$ENDIF} + FSize: Int64; + FTimeStamp: TDateTime; + Protected +{$IFDEF USEGENERIC} + procedure InitWatch(ABaseDir: String; AList: TFPStringHashTable); +{$ENDIF} + Public + Property TimeStamp : TDateTime Read FTimeStamp Write FTimeStamp; + Property Size : Int64 Read FSize Write FSize; + Property Attributes : Integer Read FAttributes Write FAttributes; +{$IFDEF UNIX} + Property Mode : mode_t Read FMode Write FMode; + Property Owner : uid_t Read FOwner Write FOwner; + Property Group : gid_t Read FGroup Write FGroup; +{$ENDIF} + Published + Property Name : String Read FName Write FName; + Property Events : TFileEvents Read FEvents Write FEvents; + end; + + { TDirectoryEntries } + + TDirectoryEntries = Class(TCollection) + private + function GetE(AIndex : Integer): TDirectoryEntry; + procedure SetE(AIndex : Integer; AValue: TDirectoryEntry); + Public + Function IndexOfEntry(Const AName : String) : Integer; + Function EntryByName(Const AName : String) : TDirectoryEntry; + Function AddEntry(Const AName : String) : TDirectoryEntry; + Property Entries[AIndex : Integer] : TDirectoryEntry Read GetE Write SetE; default; + end; + + TFileEventHandler = procedure (Sender : TObject; aEntry : TDirectoryEntry; AEvents : TFileEvents) of Object; + + { TDirwatch } + + TDirwatch = Class(TComponent) + private + FIdleInterval: Cardinal; + FOnIdle: TNotifyEvent; + FOnIdleNotify: TNotifyEvent; + FTerminated: Boolean; + FThreaded: Boolean; + FWatches: TDirectoryEntries; + FBaseDir: String; + FOnChange: TFileEventHandler; +{$IFDEF USEGENERIC} + FReference : TFPStringHashTable; + FOldReference : TFPStringHashTable; + procedure DoCheckItem(Item: String; const Key: string; var Continue: Boolean); + procedure DoDeletedItem(Item: String; const Key: string; var Continue: Boolean); +{$ENDIF} +{$IFDEF USEINOTIFY} + FINotifyFD : Cint; +{$ENDIF} + function DirectoryEntryForFileName(S: String): TDirectoryEntry; + procedure DoChangeEvent(Entry: TDirectoryEntry; Events: TFileEvents); + procedure SetBaseDir(AValue: String); + Protected + procedure DoIdle; virtual; + procedure Check; virtual; + procedure DoneWatch; virtual; + procedure DoStartWatch; virtual; + procedure InitWatch;virtual; + Public + Constructor Create(AOWner : TComponent); override; + Destructor Destroy; override; + Procedure StartWatch; + Procedure AddWatch(const aFileName : string; aEvents : TFileEvents); + Procedure Terminate; + Property Terminated : Boolean Read FTerminated; + Published + Property BaseDir : String read FBaseDir Write SetBaseDir; + Property OnChange : TFileEventHandler Read FOnChange Write FOnChange; + Property Threaded : Boolean Read FThreaded Write FThreaded; + Property Watches : TDirectoryEntries Read FWatches Write FWatches; + Property OnIdle : TNotifyEvent Read FOnIdle Write FOnIdleNotify; + Property IdleInterval : Cardinal Read FIdleInterval Write FIdleInterval; + end; + +Const + EventNames : Array[TFileEvent] of string = ('Modify','Attrib','Create','Delete'); + AllEvents = [feModify,feAttrib,feCreate,feDelete]; + +Function FileEventsToStr(Events : TFileEvents) : String; + +implementation + + +Function FileEventsToStr(Events : TFileEvents) : String; + +Var + E : TFileEvent; + +begin + Result:=''; + for E in Events do + begin + if Result<>'' then + Result:=Result+','; + Result:=Result+EventNames[E]; + end; + +end; + +{ TDirwatch } +Type + + { TDirwatchThread } + + TDirwatchThread = class(TThread) + Private + FDir:TDirWatch; + Public + Constructor Create(ADirwatch : TDirWatch); + Procedure Execute; override; + end; + +{ TDirectoryEntry } + +Function SearchRecToString(Info : TSearchRec; AEvents : TFileEvents) : String; + +begin + if feAttrib in AEvents then + Result:=IntToStr(Info.Attr) + else + Result:=''; + Result:=Result+';'+IntToStr(Info.Size)+';'+IntToStr(Info.Time); +end; + +{$IFDEF USEGENERIC} +procedure TDirectoryEntry.InitWatch(ABaseDir: String; AList: TFPStringHashTable); + +Var + Info : TSearchRec; + FN : String; + +begin + if (ABaseDir<>'') then + FN:=IncludeTrailingPathDelimiter(ABaseDir)+Name + else + FN:=Name; + if FindFirst(FN,faAnyFile,Info)=0 then + begin + if (faDirectory and Info.Attr) = 0 then + begin + AList.Add(FN,SearchRecToString(Info,Self.Events)) + end + else + begin + FindClose(Info); + FN:=IncludeTrailingPathDelimiter(FN); + if FindFirst(FN+AllFilesMask,0,Info)=0 then + Repeat + if (info.Name<>'.') and (Info.Name<>'..') then + AList.Add(FN+Info.Name,SearchRecToString(Info,Self.Events)); + until (FindNext(Info)<>0) + end; + FindClose(Info); + end +end; + +{$ENDIF} +{$IFDEF USEINOTIFY} + +{$ENDIF} +{ TDirwatchThread } + +constructor TDirwatchThread.Create(ADirwatch: TDirWatch); + +begin + FDir:=ADirWatch; + FreeOnTerminate:=True; + inherited create(False); +end; + +procedure TDirwatchThread.Execute; +begin + FDir.DoStartWatch; +end; + + +procedure TDirwatch.SetBaseDir(AValue: String); +begin + if FBaseDir=AValue then Exit; + FBaseDir:=AValue; + FWatches.Clear; +end; + +constructor TDirwatch.Create(AOWner: TComponent); +begin + inherited Create(AOWner); + FWatches:=TDirectoryEntries.Create(TDirectoryEntry); + FidleInterval:=100; +end; + +destructor TDirwatch.Destroy; +begin + FreeAndNil(FWatches); + inherited Destroy; +end; + +Type + { TDirwatchChange } + TDirwatchChange = Class + FEntry : TDirectoryEntry; + FEvents : TFileEvents; + FDirWatch : TDirWatch; + Constructor Create(AEntry : TDirectoryEntry;aEvents : TFileEvents;ADirWatch : TDirWatch); + Procedure DoEvent; + end; + +{ TDirwatchChange } + +constructor TDirwatchChange.Create(AEntry: TDirectoryEntry; aEvents: TFileEvents; ADirWatch: TDirWatch); + +begin + FEntry:=AEntry; + FEvents:=AEvents; + FDirWatch:=ADirWatch; +end; + +procedure TDirwatchChange.DoEvent; +begin + FDirwatch.FonChange(FDirwatch,FEntry,FEvents); +end; + +Procedure TDirwatch.DoChangeEvent(Entry : TDirectoryEntry; Events : TFileEvents); + +Var + W : TDirWatchChange; + +begin + try + if Assigned(FOnChange) then + if Not Threaded then + FonChange(Self,Entry,Events) + else + begin + W:=TDirWatchChange.Create(Entry,Events,Self); + try + TThread.Synchronize(TThread.CurrentThread,@W.DoEvent) + finally + W.Free; + end; + end + Finally + // Specially created + if Entry.Collection=Nil then + FreeAndNil(Entry); + end; +end; + + +procedure TDirwatch.DoIdle; + +begin + if Assigned(FOnIdle) then + FOnIdle(Self); +end; + +Function TDirwatch.DirectoryEntryForFileName(S : String) : TDirectoryEntry; + +begin + Result:=FWatches.EntryByName(S); + if (Result=Nil) then + Result:=FWatches.EntryByName(ExtractFilePath(S)); + if (Result=Nil) then + begin + Result:=TDirectoryEntry.Create(Nil); + Result.Name:=S; + end; +end; + +{$IFDEF USEGENERIC} +procedure TDirwatch.DoneWatch; + +begin + FreeAndNil(FReference); +end; + +procedure TDirwatch.InitWatch; + +Var + I : Integer; + +begin + FReference:=TFPStringHashTable.Create; + For I:=0 to FWatches.Count-1 do + FWatches[i].InitWatch(BaseDir,FReference); +end; + +procedure TDirwatch.DoDeletedItem(Item: String; const Key: string; var Continue: Boolean); + +Var + DE : TDirectoryEntry; + +begin + DE:=FWatches.EntryByName(Key); + if (DE=Nil) then + DE:=FWatches.EntryByName(ExtractFilePath(Key)); + if (DE=Nil) then + begin + DE:=TDirectoryEntry.Create(Nil); + DE.Name:=Key; + end; + DoChangeEvent(DE,[feDelete]); + Continue:=False; +end; + +procedure TDirwatch.DoCheckItem(Item: String; const Key: string; var Continue: Boolean); + +Var + S : String; + E : TFileEvents; + DE : TDirectoryEntry; + +begin +// Writeln('check file: ',key,' attrs : ',Item); + E:=[]; + S:=FOldReference[Key]; + if (S='') then + E:=[feCreate] + else + begin + FOldReference.Delete(Key); + if (S<>Item) then + E:=[feAttrib]; + end; + if E<>[] then + begin + DE:=DirectoryEntryForFileName(Key); + DoChangeEvent(DE,E); + Continue:=False; + end; +end; + +procedure TDirwatch.Check; + +begin + FOldReference:=FReference; + try + FReference:=TFPStringHashTable.Create; + InitWatch; + FReference.Iterate(@doCheckItem); + if FoldReference.Count>0 then + FReference.Iterate(@doDeletedItem); + // Deleted files + Sleep(IdleInterval); + finally + FreeAndNil(FoldReference); + end; +end; +{$ENDIF} + +{$IFDEF USEINOTIFY} +Procedure WatchDirectory(d : string); + +Const + Events = IN_MODIFY or IN_ATTRIB or IN_CREATE or IN_DELETE; + +Var + fd, wd,fnl,len : cint; + fds : tfdset; + e : ^inotify_event; + buf : Array[0..1023*4] of Byte; // 4K Buffer + fn : string; + p : pchar; + +begin + fd:=inotify_init; + try + wd:=inotify_add_watch(fd,pchar(d),Events); + fpFD_Zero(fds); + fpFD_SET(fd,fds); + While (fpSelect(fd+1,@fds,nil,nil,nil)>=0) do + begin + len:=fpRead(fd,buf,sizeof(buf)); + e:=@buf; + While ((pchar(e)-@buf)<len) do + begin + fnl:=e^.len; + if (fnl>0) then + begin + p:=@e^.name+fnl-1; + While (p^=#0) do + begin + dec(p); + dec(fnl); + end; + end; + setlength(fn,fnl); + if (fnl>0) then + move(e^.name,fn[1],fnl); + Writeln('Change ',e^.mask,' (', +// InotifyEventsToString(e^.mask), + ') detected for file "',fn,'"'); + ptrint(e):=ptrint(e)+sizeof(inotify_event)+e^.len-1; + end; + end; + finally + fpClose(fd); + end; +end; + +procedure TDirwatch.DoneWatch; + +begin + fpClose(FInotifyFD); +end; + +procedure TDirwatch.InitWatch; + +Const + NativeEvents : Array[TFileEvent] of cint = (IN_Modify,IN_Attrib,IN_Create,IN_Delete); + +Var + WD,I,NEvents : Integer; + E : TFileEvent; + BD,FN : String; + +begin + BD:=BaseDir; + if BD<>'' then + BD:=IncludeTrailingPathDelimiter(BD); + FINotifyFD:=inotify_init; + For I:=0 to FWatches.Count-1 do + begin + NEvents:=0; + for E in FWatches[i].Events do + NEvents:=NEvents OR NativeEvents[E]; + FN:=BD+FWatches[i].Name; + wd:=inotify_add_watch(FINotifyFD,PChar(FN),NEvents); + end; +end; + +Function NativeEventsToEvents(Native : cint) : TFileEvents; + + Procedure MA(C : cint; AEvent : TFileEvent); + + begin + if (Native and C)<>0 then + Include(Result,AEvent); + end; + +begin + Result:=[]; + MA(IN_ACCESS,feAttrib); + MA(IN_MODIFY,feModify); + MA(IN_ATTRIB,feAttrib); + MA(IN_CLOSE_WRITE,feAttrib); + MA(IN_CLOSE_NOWRITE,feAttrib); + MA(IN_OPEN,feAttrib); + MA(IN_MOVED_FROM,feCreate); + MA(IN_MOVED_TO,feDelete); + MA(IN_CREATE,feCreate); + Ma(IN_DELETE,feDelete); + Ma(IN_DELETE_SELF,feDelete); + Ma(IN_MOVE_SELF,feDelete); + Ma(IN_UNMOUNT,feDelete); + // IN_Q_OVERFLOW + // IN_IGNORED + +end; + +procedure TDirwatch.Check; + +Var + fnl,len : cint; + e : ^inotify_event; + buf : Array[0..1023*4] of Byte; // 4K Buffer + fn : string; + p : pchar; + fds : tfdset; + Timeout : ttimeval; + +begin + fpFD_Zero(fds); + fpFD_SET(FINotifyFD,fds); + timeout.tv_sec:=FIdleInterval div 1000; + timeout.tv_usec:=(FIdleInterval mod 1000)*1000; + if (fpSelect(FINotifyFD+1,@fds,nil,nil,@Timeout)<=0) then + exit; + len:=fpRead(FINotifyFD,buf,sizeof(buf)); + e:=@buf; + While ((pchar(e)-@buf)<len) do + begin + fnl:=e^.len; + if (fnl>0) then + begin + p:=@e^.name+fnl-1; + While (p^=#0) do + begin + dec(p); + dec(fnl); + end; + end; + setlength(fn,fnl); + if (fnl>0) then + move(e^.name,fn[1],fnl); + DoChangeEvent(DirectoryEntryForFileName(FN),NativeEventsToEvents(E^ .mask)); + ptrint(e):=ptrint(e)+sizeof(inotify_event)+e^.len-1; + end; +end; +{$ENDIF} + +procedure TDirwatch.DoStartWatch; + +begin + InitWatch; + try + While not Terminated do + begin + Check; + if Threaded then + TThread.Synchronize(TThread.CurrentThread,@DoIdle) + else + DoIdle; + end; + Finally + DoneWatch; + end; +end; + +procedure TDirwatch.StartWatch; + +begin + If Threaded then + TDirwatchThread.Create(Self).WaitFor + else + DoStartWatch; +end; + +procedure TDirwatch.AddWatch(const aFileName: string; aEvents: TFileEvents); +begin + FWatches.AddEntry(AFileName).Events:=AEvents; +end; + +procedure TDirwatch.Terminate; +begin + FTerminated:=True; +end; + +{ TDirectoryEntries } + +function TDirectoryEntries.GetE(AIndex : Integer): TDirectoryEntry; +begin + Result:=TDirectoryEntry(Items[AIndex]); +end; + +procedure TDirectoryEntries.SetE(AIndex : Integer; AValue: TDirectoryEntry); +begin + Items[AIndex]:=AValue; +end; + +function TDirectoryEntries.IndexOfEntry(const AName: String): Integer; + +begin + Result:=Count-1; + While (Result>=0) and (GetE(Result).Name<>AName) do + Dec(Result); +end; + +function TDirectoryEntries.EntryByName(const AName: String): TDirectoryEntry; + +Var + I : Integer; + +begin + I:=IndexOfEntry(AName); + If (I=-1) then + Result:=Nil + else + Result:=GetE(I); +end; + +function TDirectoryEntries.AddEntry(Const AName: String): TDirectoryEntry; +begin + Result:=Add as TDirectoryEntry; + Result.Name:=AName; +end; + +end. + diff --git a/utils/pas2js/fpmake.pp b/utils/pas2js/fpmake.pp index 44b032cc2d..422ab71130 100644 --- a/utils/pas2js/fpmake.pp +++ b/utils/pas2js/fpmake.pp @@ -30,8 +30,12 @@ begin P.Dependencies.Add('fcl-js'); P.Dependencies.Add('fcl-passrc'); P.Dependencies.Add('pastojs'); + P.Dependencies.Add('fcl-web'); PT:=P.Targets.AddProgram('pas2js.pp'); PT:=P.Targets.AddLibrary('pas2jslib.pp'); + PT:=P.Targets.AddUnit('httpcompiler.pp'); + PT:=P.Targets.AddProgram('compileserver.pp'); + PT.Dependencies.AddUnit('httpcompiler'); end; end; diff --git a/utils/pas2js/httpcompiler.pp b/utils/pas2js/httpcompiler.pp new file mode 100644 index 0000000000..cdc4417ecb --- /dev/null +++ b/utils/pas2js/httpcompiler.pp @@ -0,0 +1,528 @@ +unit httpcompiler; + +{$mode objfpc} +{$H+} + +interface + +uses + sysutils, classes, fpjson, contnrs, syncobjs, custhttpapp, fpwebfile, httproute, + pas2jscompiler, httpdefs, dirwatch; + +Const + nErrTooManyThreads = -1; + +Type + TDirWatcher = Class; + THTTPCompilerApplication = Class; + + { TCompileItem } + + TCompileItem = Class(TCollectionItem) + private + FBaseDir: string; + FConfigFile: String; + FFileName: string; + FOutput : TStrings; + FOptions : TStrings; + FSuccess: Boolean; + FThread: TThread; + function GetOptions: TStrings; + function GetOutput: TStrings; + Public + Destructor Destroy; override; + Property BaseDir : string Read FBaseDir Write FBaseDir; + Property FileName : string Read FFileName Write FFileName; + Property ConfigFile: String Read FConfigFile Write FConfigFile; + Property Options : TStrings Read GetOptions; + Property Output : TStrings Read GetOutput; + Property Thread : TThread Read FThread; + Property Success : Boolean Read FSuccess; + end; + + { TCompiles } + + TCompiles = Class(TCollection) + private + function GetC(AIndex : Integer): TCompileItem; + Public + Property Compiles[AIndex : Integer] : TCompileItem Read GetC; default; + end; + + + { TCompileThread } + + TCompileThread = class(TThread) + private + FApp : THTTPCompilerApplication; + FItem: TCompileItem; + procedure DoCompilerLog(Sender: TObject; const Msg: String); + procedure SetItem(AValue: TCompileItem); + Public + Constructor create(App : THTTPCompilerApplication; aItem : TCompileItem); + Procedure Execute; override; + Property Item : TCompileItem read FItem write SetItem; + end; + + { TDirWatcher } + + TDirWatcher = Class(TComponent) + Private + FApp : THTTPCompilerApplication; + FDW : TDirWatch; + procedure DoChange(Sender: TObject; aEntry: TDirectoryEntry; AEvents: TFileEvents); + Public + Constructor Create(App : THTTPCompilerApplication; ADir : String);overload; + Destructor Destroy; override; + end; + + { THTTPCompilerApplication } + + THTTPCompilerApplication = Class(TCustomHTTPApplication) + private + FBaseDir: String; + FConfigFile: String; + FProjectFile: String; + FStatusLock : TCriticalSection; + FQuiet: Boolean; + FWatch: Boolean; + FDW : TDirWatcher; + FStatusList : TFPObjectList; + FCompiles : TCompiles; + procedure AddToStatus(O: TJSONObject); + Procedure ReportBuilding(AItem : TCompileItem); + Procedure ReportBuilt(AItem : TCompileItem); + Procedure AddToStatus(AEntry : TDirectoryEntry; AEvents : TFileEvents); + procedure DoStatusRequest(ARequest: TRequest; AResponse: TResponse); + procedure DoRecompile(ARequest: TRequest; AResponse: TResponse); + function ScheduleCompile(const aProjectFile: String; Options : TStrings = Nil): Integer; + procedure StartWatch(ADir: String); + procedure Usage(Msg: String); + public + Constructor Create(AOWner : TComponent); override; + Destructor Destroy; override; + procedure DoLog(EventType: TEventType; const Msg: String); override; + Procedure DoRun; override; + property Quiet : Boolean read FQuiet Write FQuiet; + Property Watch : Boolean Read FWatch Write FWatch; + Property ProjectFile : String Read FProjectFile Write FProjectFile; + Property ConfigFile : String Read FConfigFile Write FConfigFile; + Property BaseDir : String Read FBaseDir; + end; + +Implementation + +{ TCompileThread } + +procedure TCompileThread.SetItem(AValue: TCompileItem); +begin + if FItem=AValue then Exit; + FItem:=AValue; +end; + +procedure TCompileThread.DoCompilerLog(Sender: TObject; const Msg: String); +begin + If Assigned(Item) then + Item.Output.Add(Msg); +end; + +constructor TCompileThread.create(App: THTTPCompilerApplication; aItem: TCompileItem); + +begin + FItem:=aItem; + FApp:=App; + FreeOnTerminate:=True; + inherited create(False); +end; + +procedure TCompileThread.Execute; + +Var + C : TPas2jsCompiler; + L : TStrings; + +begin + L:=Nil; + C:=TPas2jsCompiler.Create; + Try + FApp.ReportBuilding(Item); + L:=TStringList.Create; + L.Assign(Item.Options); + if (Item.ConfigFile<>'') then + L.Add('@'+Item.ConfigFile); + L.Add(Item.FileName); + C.Log.OnLog:=@DoCompilerLog; + try + C.Run(ParamStr(0),Item.BaseDir,L,True); + Item.FSuccess:=True; + except + On E : Exception do + Item.Output.Add(Format('Error %s compiling %s: %s',[E.ClassName,Item.FileName,E.Message])); + end; + FApp.ReportBuilt(Item); + Finally + C.Free; + L.Free; + end; + Item.FThread:=Nil; +end; + +{ TCompiles } + +function TCompiles.GetC(AIndex : Integer): TCompileItem; +begin + Result:=Items[Aindex] as TCompileItem; +end; + +{ TCompileItem } + +function TCompileItem.GetOutput: TStrings; +begin + If (FOutput=Nil) then + FOutput:=TStringList.Create; + Result:=FOutput; +end; + +function TCompileItem.GetOptions: TStrings; +begin + If (FOptions=Nil) then + FOptions:=TStringList.Create; + Result:=FOptions; +end; + +destructor TCompileItem.Destroy; +begin + FreeAndNil(FOutput); + FreeAndNil(FOptions); + inherited Destroy; +end; + + +{ TDirWatcher } + +procedure TDirWatcher.DoChange(Sender: TObject; aEntry: TDirectoryEntry; AEvents: TFileEvents); +begin + if Assigned(FApp) then + FApp.AddToStatus(AEntry,AEvents); +end; + +constructor TDirWatcher.Create(App: THTTPCompilerApplication; ADir: String); +begin + Inherited create(APP); + FApp:=App; + FDW:=TDirwatch.Create(Self); + FDW.AddWatch(ADir,allEvents); + FDW.OnChange:=@DoChange; + TThread.ExecuteInThread(@FDW.StartWatch); +end; + +destructor TDirWatcher.Destroy; +begin + FApp:=Nil; + FDW.Terminate; + FreeAndNil(FDW); + inherited Destroy; +end; + +{ THTTPCompilerApplication } + +procedure THTTPCompilerApplication.DoLog(EventType: TEventType; const Msg: String); +begin + if Quiet then + exit; + if IsConsole then + Writeln(FormatDateTime('yyyy-mm-dd hh:nn:ss.zzz',Now),' [',EventType,'] ',Msg) + else + inherited DoLog(EventType, Msg); +end; + +procedure THTTPCompilerApplication.Usage(Msg : String); + +begin + if (Msg<>'') then + Writeln('Error: ',Msg); + Writeln('Usage ',ExtractFileName(ParamStr(0)),' [options] '); + Writeln('Where options is one or more of : '); + Writeln('-d --directory=dir Base directory from which to serve files.'); + Writeln(' Default is current working directory: ',GetCurrentDir); + Writeln('-h --help This help text'); + Writeln('-i --indexpage=name Directory index page to use (default: index.html)'); + Writeln('-n --noindexpage Do not allow index page.'); + Writeln('-p --port=NNNN TCP/IP port to listen on (default is 3000)'); + Writeln('-q --quiet Do not write diagnostic messages'); + Writeln('-w --watch Watch directory for changes'); + Writeln('-c --compile[=proj] Recompile project if pascal files change. Default project is app.lpr'); + Halt(Ord(Msg<>'')); +end; + +constructor THTTPCompilerApplication.Create(AOWner: TComponent); +begin + inherited Create(AOWner); + FStatusLock:=TCriticalSection.Create; + FStatusList:=TFPObjectList.Create(False); + FCompiles:=TCompiles.Create(TCompileItem); +end; + +destructor THTTPCompilerApplication.Destroy; +begin + FStatusLock.Enter; + try + FreeAndNil(FCompiles); + FreeAndNil(FStatusList); + finally + FStatusLock.Leave; + end; + FreeAndNil(FStatusLock); + inherited Destroy; +end; + +procedure THTTPCompilerApplication.StartWatch(ADir : String); + +begin + FDW:=TDirWatcher.Create(Self,ADir); +end; + +procedure THTTPCompilerApplication.ReportBuilding(AItem: TCompileItem); + +Var + O : TJSONObject; + +begin + O:=TJSONObject.Create(['action','building','compileID',AItem.ID,'project',AItem.FileName,'config',AItem.ConfigFile]); + AddToStatus(O); +end; + +procedure THTTPCompilerApplication.ReportBuilt(AItem: TCompileItem); + +Var + O : TJSONObject; + A : TJSONArray; + I : Integer; + +begin + A:=TJSONArray.Create; + For I:=0 to AItem.Output.Count-1 do + A.Add(AItem.Output[i]); + O:=TJSONObject.Create(['action','built','compileID',AItem.ID,'project',AItem.FileName,'config',AItem.ConfigFile,'output',A,'success',AItem.Success]); + AddToStatus(O); +end; + +procedure THTTPCompilerApplication.AddToStatus(O : TJSONObject); + +begin + FStatusLock.Enter; + try + Writeln('Adding to status ',Assigned(O),' : ',O.ClassName); + FStatusList.Add(O); + finally + FStatusLock.Leave; + end; +end; + +procedure THTTPCompilerApplication.AddToStatus(AEntry: TDirectoryEntry; AEvents: TFileEvents); + +Var + O : TJSONObject; + FN : String; + +begin + Log(etDebug,'File change detected: %s (%s)',[AEntry.name,FileEventsToStr(AEvents)]); + O:=TJSONObject.Create(['action','file','name',AEntry.name,'events',FileEventsToStr(AEvents)]); + if Pos(ExtractFileExt(AEntry.Name),'.lpr.pas.pp.inc.dpr')>0 then + FN:=AEntry.Name; + if (FN<>'') then + O.Add('recompile',true); + AddToStatus(O); + if (FN<>'') then + begin + Log(etDebug,'File change forces recompile: %s',[AEntry.name]); + ScheduleCompile('',Nil); + end; +end; + +procedure THTTPCompilerApplication.DoStatusRequest(ARequest : TRequest; AResponse : TResponse); + +Var + R,O : TJSONObject; + A : TJSONArray; + I : integer; +begin + Log(etDebug,'Status request from: %s',[ARequest.RemoteAddress]); + R:=Nil; + try + FStatusLock.Enter; + try + if (FStatusList.Count=0) then + R:=TJSONObject.Create(['ping',True]) + else + begin + Writeln(FStatusList[0].ClassName); + O:=FStatusList[0] as TJSONObject; + FStatusList.Delete(0); + if O.Get('action','')<>'file' then + R:=O + else + begin + // If first event is file event, then add and delete all file events in list. + A:=TJSONArray.Create([O]); + O.Delete('action'); + R:=TJSONObject.Create(['action','sync','files',A]); + For I:=FStatusList.Count-1 downto 0 do + begin + O:=FStatusList[I] as TJSONObject; + if (O.Get('action','')='file') then + begin + A.Add(O); + O.Delete('action'); + FStatusList.Delete(I); + end; + end; + end + end; + finally + FStatusLock.Leave; + end; + AResponse.ContentType:='application/json'; + AResponse.Content:=R.AsJSON; + AResponse.SendResponse; + finally + R.Free; + end; +end; + +Function THTTPCompilerApplication.ScheduleCompile(const aProjectFile : String; Options : TStrings = Nil) : Integer; + +Var + CI : TCompileItem; + I,TC : Integer; + +begin + TC:=0; + For I:=0 to FCompiles.Count-1 do + if Assigned(FCompiles[I].THread) then + Inc(TC); + if TC>10 then + begin + Log(etError,'Refusing compile of file "%s" using config file "%s"',[AProjectFile, ConfigFile]); + Exit(nErrTooManyThreads); + end; + CI:=FCompiles.Add as TCompileItem; + Log(etInfo,'Scheduling compile ID %d of file "%s" using config file "%s"',[CI.ID,AProjectFile, ConfigFile]); + CI.BaseDir:=BaseDir; + CI.FileName:=AProjectFile; + CI.ConfigFile:=ConfigFile; + if Assigned(Options) then + CI.Options.Assign(Options); + TCompileThread.Create(Self,CI); + Result:=CI.ID; +end; + +procedure THTTPCompilerApplication.DoRecompile(ARequest: TRequest; AResponse: TResponse); + +Var + ID : Integer; + PF,CL : String; + Options: TStrings; + +begin + PF:=ARequest.ContentFields.Values['ProjectFile']; + CL:=ARequest.ContentFields.Values['CompileOptions']; + if PF='' then + PF:=ProjectFile; + If (PF='') then + begin + AResponse.Code:=404; + AResponse.CodeText:='No project file'; + AResponse.ContentType:='application/json'; + AResponse.Content:='{ "success" : false, "message": "no project file set or provided" }'; + end + else + begin + Options:=Nil; + try + if CL<>'' then + begin + Options:=TStringList.Create; + Options.Text:=Cl; + end; + ID:=ScheduleCompile(PF,Options); + finally + FreeAndNil(Options); + end; + if ID=nErrTooManyThreads then + begin + AResponse.Code:=403; + AResponse.CodeText:='Too many compiles'; + AResponse.ContentType:='application/json'; + AResponse.Content:='{ "success" : false, "message": "Too many compiles running" }'; + end + else + begin + AResponse.Code:=200; + AResponse.ContentType:='application/json'; + AResponse.Content:=Format('{ "success" : true, "file": "%s", "commandLine" : "%s", "compileID": %d }',[StringToJSONString(PF),StringToJSONString(CL),ID]); + end + end; + AResponse.SendResponse; +end; + +procedure THTTPCompilerApplication.DoRun; + +Var + S,IndexPage,D : String; + +begin + S:=Checkoptions('hqd:ni:p:wP::c',['help','quiet','noindexpage','directory:','port:','indexpage:','watch','project::','config:']); + if (S<>'') or HasOption('h','help') then + usage(S); + Quiet:=HasOption('q','quiet'); + Watch:=HasOption('w','watch'); + Port:=StrToIntDef(GetOptionValue('p','port'),3000); + D:=GetOptionValue('d','directory'); + if D='' then + D:=GetCurrentDir; + Log(etInfo,'Listening on port %d, serving files from directory: %s',[Port,D]); +{$ifdef unix} + MimeTypesFile:='/etc/mime.types'; +{$endif} + if Hasoption('P','project') then + begin + ProjectFile:=GetOptionValue('P','project'); + if ProjectFile='' then + ProjectFile:=IncludeTrailingPathDelimiter(D)+'app.lpr'; + If Not FileExists(ProjectFile) then + begin + Terminate; + Log(etError,'Project file "%s" does not exist, aborting.',[ProjectFile]); + Exit; + end; + ConfigFile:=GetOptionValue('c','config'); + if (ConfigFile='') then + ConfigFile:=ChangeFileExt(Projectfile,'.cfg'); + if not FileExists(ConfigFile) then + ConfigFile:=''; + end; + if Watch then + begin + if (ProjectFile='') then + Log(etWarning,'No project file specified, disabling watch.') ; + StartWatch(D); + end; + FBaseDir:=D; + TSimpleFileModule.BaseDir:=IncludeTrailingPathDelimiter(D); + TSimpleFileModule.OnLog:=@Log; + If not HasOption('n','noindexpage') then + begin + IndexPage:=GetOptionValue('i','indexpage'); + if (IndexPage='') then + IndexPage:='index.html'; + Log(etInfo,'Using index page %s',[IndexPage]); + TSimpleFileModule.IndexPageName:=IndexPage; + end; + httprouter.RegisterRoute('$sys/compile',rmPost,@DoRecompile); + httprouter.RegisterRoute('$sys/status',rmGet,@DoStatusRequest); + TSimpleFileModule.RegisterDefaultRoute; + inherited; +end; + +end.