{$MODE OBJFPC} { -*- text -*- } {$INCLUDE settings.inc} program cuddlyworld; uses {$IFDEF DEBUG} debug, {$ENDIF} sysutils, baseunix, client, corenetwork, exceptions, storable, physics, world, locations, player, cuddlycamp; type TMain = class constructor Create(); destructor Destroy(); override; procedure Run(); virtual; abstract; procedure ReportException(E: Exception); protected FWorld: TWorld; FOldReportExceptionMethod: TReportExceptionEvent; procedure InitialiseWorld(); procedure SaveWorld(); {$IFDEF DEBUG} procedure ReportStatus(Perspective: TPlayer); {$ENDIF} end; TNetworkMain = class(TMain) constructor Create(); destructor Destroy(); override; procedure Run(); override; protected FServer: TCuddlyWorldServer; end; TCommandLineMain = class(TMain) constructor Create(Username, Password: UTF8String); destructor Destroy(); override; procedure Run(); override; procedure HandleForceDisconnect(); procedure HandleAvatarMessage(Message: UTF8String); protected FPlayer: TPlayer; end; var Aborted: Boolean = False; procedure SigIntHandler(Signal: Longint; Info: PSigInfo; Context: PSigContext); cdecl; begin Aborted := True; end; constructor TMain.Create(); var NewAction: PSigActionRec; begin Writeln('CuddlyWorld initializing...'); inherited; {$IFDEF DEBUG} Writeln('CuddlyWorld debugging enabled.'); player.StatusReport := @Self.ReportStatus; {$ENDIF} InitialiseWorld(); New(NewAction); if (not Assigned(NewAction)) then OutOfMemoryError(); try NewAction^.sa_handler := @SigIntHandler; NewAction^.sa_flags := SA_ONESHOT; {$ifdef Linux} NewAction^.sa_restorer := nil; {$endif} FillByte(NewAction^.sa_mask, SizeOf(NewAction^.sa_mask), 0); if (fpSigAction(SIGINT, NewAction, nil) <> 0) then raise EKernelError.Create(fpGetErrNo); finally Dispose(NewAction); end; FOldReportExceptionMethod := SetReportExceptionMethod(@Self.ReportException); end; procedure TMain.InitialiseWorld(); begin FWorld := ReadObjectFromFile(kWorldFileName) as TWorld; if (not Assigned(FWorld)) then raise Exception.Create('World not found. Run genesis to create ' + kWorldFileName + ' before running cuddlyworld.'); end; procedure TMain.SaveWorld(); begin StoreObjectToFile(kWorldFileName, FWorld, kSaveDataVersion); FWorld.Saved(); end; destructor TMain.Destroy(); begin {$IFDEF DEBUG} player.StatusReport := nil; {$ENDIF} FWorld.Free(); SetReportExceptionMethod(FOldReportExceptionMethod); inherited; end; procedure TMain.ReportException(E: Exception); begin Writeln(E.Message); Dump_Stack(Output, Get_Frame); end; {$IFDEF DEBUG} procedure TMain.ReportStatus(Perspective: TPlayer); begin Perspective.SendRawMessage('Players: ' + IntToStr(FWorld.GetPlayerCount())); end; {$ENDIF} constructor TNetworkMain.Create(); begin inherited; FServer := TCuddlyWorldServer.Create(10000, FWorld); end; destructor TNetworkMain.Destroy(); begin FServer.Free(); inherited; end; procedure TNetworkMain.Run(); begin Writeln('CuddlyWorld running...'); repeat FServer.Select(timeoutForever); FWorld.CheckForDisconnectedPlayers(); EmptyDisposalQueue(); if (FWorld.Dirty) then SaveWorld(); until Aborted; Writeln('CuddlyWorld aborted'); end; constructor TCommandLineMain.Create(Username, Password: UTF8String); begin inherited Create(); FPlayer := FWorld.GetPlayer(Username) as TPlayer; if (Assigned(FPlayer)) then begin if (FPlayer.GetPassword() = Password) then begin FPlayer.Adopt(@Self.HandleAvatarMessage, @Self.HandleForceDisconnect); Writeln('Logged in as ' + FPlayer.GetDefiniteName(nil) + '.'); Writeln(''); FPlayer.DoLook(); FPlayer.DoInventory(); Writeln(''); end else begin raise Exception.Create('Wrong Password'); end; end else begin FPlayer := TPlayer.Create(Username, Password, gOrb); FPlayer.Adopt(@Self.HandleAvatarMessage, @Self.HandleForceDisconnect); FWorld.AddPlayer(FPlayer); { this puts it into the world } FPlayer.AnnounceAppearance(); Writeln('Welcome to CuddlyWorld, ' + FPlayer.GetDefiniteName(nil) + '.'); Writeln(''); FPlayer.DoLook(); Writeln(''); end; end; procedure TCommandLineMain.HandleAvatarMessage(Message: UTF8String); begin Writeln(Message); end; procedure TCommandLineMain.HandleForceDisconnect(); begin end; destructor TCommandLineMain.Destroy(); begin FPlayer.Abandon(); inherited; end; procedure TCommandLineMain.Run(); var S: UTF8String; begin repeat Write('> '); Readln(S); FPlayer.Perform(S); EmptyDisposalQueue(); SaveWorld(); until Aborted; end; var Main: TMain; begin {$IFDEF DEBUG} RegisterStorableClassSynonym('TTestWorld', TWorld); {$ENDIF} try if (ParamCount() > 0) then begin if (ParamCount() <> 2) then begin Writeln('Usage: cuddlyworld [username password]'); Writeln('Without arguments, runs a WebSocket server on a port in the range 10000..10009.'); Writeln('With arguments, runs locally in single-user mode using the given username and password.'); end else begin Main := TCommandLineMain.Create(ParamStr(1), ParamStr(2)); end; end else begin Main := TNetworkMain.Create(); end; try Main.Run(); finally Main.Free(); end; except on E: Exception do begin Writeln(E.Message); DumpExceptionBackTrace(Output); end; end; end.