mORMot Open Source

   // first release any deprecated instances
    if fInstanceTimeout<>0 then
    for i := fInstancesCount-1 downto 0 do
      with fInstances[i] do
      if InstanceID<>0 then
      if (Inst.LastAccess<LastAccess) or
         (QWord(Inst.LastAccess)>QWord(LastAccess)+QWord(fInstanceTimeout)) then begin
        // mark this entry is empty
        {$ifdef WITHLOG}
        SQLite3Log.Add.Log(sllServiceCall,
          'Deleted % instance (id=%) after % ms timeout (max % ms)',
          [fInterfaceURI,InstanceID,Inst.LastAccess-LastAccess,fInstanceTimeOut],self);
        {$endif}
        SafeFreeInstance({$ifndef LVCL}fImplementationFreeInMainThread{$endif});   // <-- this line raises the error
      end;

if not Ctxt.Authenticate then

requestCurrentUser: function() {
      var url = Settings.mainUrl + '/Users.GetCurrent';
      var token = getSessionSignature(url.substr(Settings.serverUrl.length + 1));
      $.ajax({
      type: "POST",
      dataType: "json",
      url: url + '?session_signature=' + token,
      data: [],
      contenttype: 'application/json; charset=utf-8',
      timeout:2000,
      success: function(response, textStatus, jqXHR) {
        return currentUser;  // As saved on local storage
      },
      error: function (jqXHR, textStatus, errorThrown) {
        console.log(jqXHR);
      }
    });

procedure TSQLRestServer.URI(var Call: TSQLRestURIParams);
var Ctxt: TSQLRestServerURIContext;
{$ifdef WITHSTATPROCESS}
    timeStart,timeEnd: Int64;
begin
  QueryPerformanceCounter(timeStart);
{$else}
begin
{$endif}
  inc(fStats.fIncomingBytes,length(Call.url)+length(call.method)+length(call.InHead)+length(call.InBody)+12);
  Call.OutInternalState := InternalState; // other threads may change it
  Call.OutStatus := HTML_BADREQUEST; // default error code is 400 BAD REQUEST
  Ctxt := ServicesRouting.Create(self,Call);
  try
    {$ifdef WITHLOG}
    Ctxt.Log := SQLite3Log.Add;
    Ctxt.Log.Enter(Self,pointer(Ctxt.URIWithoutSignature),true);
    {$endif}
    if Ctxt.Method=mNone then
      Ctxt.Error('Unknown VERB') else
    // 1. decode URI
    if not Ctxt.URIDecodeREST then
      Ctxt.Error('Invalid Root',HTML_NOTFOUND) else begin
      Ctxt.URIDecodeSOAByMethod;
      if (Ctxt.MethodIndex<0) and (Ctxt.URI<>'') and
         (reService in Call.RestAccessRights^.AllowRemoteExecute) then
        Ctxt.URIDecodeSOAByInterface;
      // 2. handle security
      if not Ctxt.Authenticate then // 403 in case of authentication failure
        // 401 Unauthorized response MUST include a WWW-Authenticate header,
        // which is not what we used, so we won't send 401 error code but 403
        Call.OutStatus := HTML_FORBIDDEN else
      // 3. call appropriate ORM / SOA commands
      try
        if Ctxt.MethodIndex>=0 then
          Ctxt.ExecuteSOAByMethod else
        if Ctxt.Service<>nil then
          Ctxt.ExecuteSOAByInterface else     // <<- this line raises 500 (Internal Server Error) 
        if  Ctxt.Method in [mLOCK,mGET,mUNLOCK,mSTATE] then
          // handle read methods
          Ctxt.ExecuteORMGet else
        // write methods (mPOST, mPUT, mDELETE...) are locked
        if AcquireWrite(Ctxt) then // make it thread-safe and transaction-safe
        try
          Ctxt.ExecuteORMWrite;
        finally
          ReleaseWrite;
        end else
          // AcquireWrite(SessionID) returned false (e.g. endless transaction)
          Call.OutStatus := HTML_TIMEOUT; // 408 Request Time-out
      except
        on E: Exception do
          Ctxt.Error('Exception %: %',
           [PShortString(PPointer(PPtrInt(E)^+vmtClassName)^)^,E.Message],
           HTML_SERVERERROR); // 500 internal server error
      end;
    end;
    // 4. returns expected result to the client and update Server statistics
    if (Call.OutStatus in [HTML_SUCCESS,HTML_CREATED]) or
       (Call.OutStatus=HTML_NOTMODIFIED) then begin
      inc(fStats.fResponses);
      {$ifdef WITHLOG}
      Ctxt.Log.Log(sllServer,'% % -> %',[Call.Method,Ctxt.URI,Call.OutStatus],self);
      {$endif}
    end else begin
      inc(fStats.fInvalid);
      if Call.OutBody='' then // if no custom error message, compute it now as JSON
        Ctxt.Error(Ctxt.CustomErrorMsg,Call.OutStatus);
    end;
    inc(fStats.fOutcomingBytes,length(Call.OutHead)+length(Call.OutBody)+16);
    if (Call.OutBody<>'') and
       (length(Call.OutHead)=Length(STATICFILE_CONTENT_TYPE_HEADER)) and
       (Call.OutHead[Length(HEADER_CONTENT_TYPE)+1]='!') and
       IdemPChar(pointer(Call.OutHead),STATICFILE_CONTENT_TYPE_HEADER) then
      inc(fStats.fOutcomingFiles);
    if (Ctxt.Static<>nil) and Ctxt.Static.fOutInternalStateForcedRefresh then
      // force always refresh for Static table which demands it
      Call.OutInternalState := cardinal(-1) else
      // database state may have changed above
      Call.OutInternalState := InternalState;
    {$ifdef WITHSTATPROCESS}
    QueryPerformanceCounter(timeEnd);
    inc(fStats.ProcessTimeCounter,timeEnd-timeStart);
    {$endif}
  finally
    Ctxt.Free;
  end;
end;

if not fInterface.fMethods[Ctxt.ServiceMethodIndex].InternalExecute(
          [PAnsiChar(Inst.Instance)+entry^.IOffset],Ctxt.ServiceParameters,WR,
           Ctxt.Call.OutHead,fExecution[Ctxt.ServiceMethodIndex].Options,
           Ctxt.ForceServiceResultAsJSONObject)

if Par^ in [#1..' '] then repeat inc(Par) until not(Par^ in [#1..' ']);
    if Par^<>'[' then
      Exit;

An error was encountered
Error: Could not connect to smtp host "mail.gandi.net" (110) (Connection timed out).

CREATE TABLE MyTable
(
  TEXTO  VARCHAR2(4000 BYTE)
)

PROCEDURE DUMMY(
    P_cursor OUT SYS_REFCURSOR
) IS
  BEGIN
    OPEN P_cursor FOR
	SELECT TEXTO FROM MyTable;
END dummy;

var
  query: RawUTF8;
  stmt: ISQLDBStatement;
  cursor: ISQLDBRows;
begin
  query :=  'BEGIN SOME_PKG.DUMMY(P_cursor => ?); END;';
  stmt := Props.NewThreadSafeStatementPrepared(query, false);
  stmt.BindCursor(1);
  stmt.ExecutePrepared;
  cursor := stmt.BoundCursor(1);     
  Result := cursor.FetchAllAsJSON(true);
end;

[
  { "TEXTO": "" },
  { "TEXTO": "" },
  { "TEXTO": "" },
  { "TEXTO": "" },
  { "TEXTO": "" },
  { "TEXTO": "" },
  { "TEXTO": "" },
  { "TEXTO": "" },
  { "TEXTO": "" },
  { "TEXTO": "" },
  { "TEXTO": "" },
  { "TEXTO": "" },
  { "TEXTO": "" },
  { "TEXTO": "" },
  { "TEXTO": "" },
  { "TEXTO": "" },
  { "TEXTO": "" },
  { "TEXTO": "" },
  { "TEXTO": "" },
  { "TEXTO": "" },
  { "TEXTO": "" },
  { "TEXTO": "" },
  { "TEXTO": "" },
  { "TEXTO": "" },
  { "TEXTO": "" },
  { "TEXTO": "" },
  { "TEXTO": "" },
  { "TEXTO": "" },
  { "TEXTO": "" },
  { "TEXTO": "" },
  { "TEXTO": "" },
  { "TEXTO": "" },
  { "TEXTO": "Some texto" }
]

unit uDBSingleton;

interface

uses
  SysUtils, SynDbOracle;

type
  TDBSingleton = class(TObject)
  public
    constructor Create;
    destructor Destroy; override;
    function GetConnection: TSQLDBOracleConnectionProperties;
  protected
    fProps: TSQLDBOracleConnectionProperties;
  end;

var
  Global_DBSingleton: TDBSingleton;

implementation

uses
  uCommons;

constructor TDBSingleton.Create;
begin
  if Global_DBSingleton <> nil then
    raise Exception.Create('Global DB Singleton already created!')
  else
    Global_DBSingleton := Self;
end;

destructor TDBSingleton.Destroy;
begin
  if Assigned(fProps) then
    fProps.Free;
  Global_DBSingleton := nil;

  inherited Destroy;
end;

function TDBSingleton.GetConnection: TSQLDBOracleConnectionProperties;
begin
  if not Assigned(Global_DBSingleton) then
    raise Exception.Create('Global DB Singleton not created!. You must call Create once.');

  if not Assigned(fProps) then
    fProps := TSQLDBOracleConnectionProperties.CreateWithCodePage(SERVER_NAME, USER_ID, USER_PASSWORD, 0);

  Result := fProps;
end;

end.

PROCEDURE dummy (
    P_cursor OUT Globales.T_c_weak_cursor,
    P_id     IN Number
  ) IS
  BEGIN
    OPEN P_cursor FOR
		    SELECT * FROM some_table T WHERE T.Id = P_id
  END dummy;

var
  id: RawUTF8;
  query: RawUTF8;
  stmt: ISQLDBStatement;
  cursor: ISQLDBRows;
begin
  id := '2000';
	
  query :=  'BEGIN SOME_PKG.DUMMY(P_cursor => ?, P_id => ?); END;';
  stmt := Props.NewThreadSafeStatementPrepared(query, false);
  stmt.BindCursor(1);
  stmt.BindTextU(2, id, paramIn);
  stmt.ExecutePrepared;
  cursor := stmt.BoundCursor(1);     
  Result := cursor.FetchAllAsJSON(true);
end;

  stmt := Self.Props.NewThreadSafeStatement;
  stmt.Prepare(query, false);
  stmt.Bind(1, ..., paramIn);
  stmt.BindTextU(2, ..., paramIn);
  stmt.BindTextU(3, ..., paramIn);
  stmt.BindTextS(4, '', paramOut);
  stmt.Bind(5, 0, paramOut);
  stmt.ExecutePrepared;
  stmt.ParamToVariant(4, out1, true);
  stmt.ParamToVariant(5, out2, true);

/// encode the supplied data as an UTF-8 valid JSON object content
// - data must be supplied two by two, as Name,Value pairs, e.g.
// ! JSONEncode(['name','John','year',1972]) = '{"name":"John","year":1972}'
// - note that cardinal values should be type-casted to Int64() (otherwise
// the integer mapped value will be transmitted, therefore wrongly)
function JSONEncode(const NameValuePairs: array of const): RawUTF8;

Result.Header := JSON_CONTENT_TYPE_HEADER;

{}

FUNCTION dummy (
  param1 IN integer, 
  param2 IN integer,
  param3 IN string,
  param4 OUT string
) RETURN INTEGER;

query :=  'call dummy (?, ?, ?, ?)';
  stmt := Props.NewThreadSafeStatementPrepared(query, false);  // it is false here??, remember, it is a function with returns some integer
  stmt.Bind(1, param1, paramIn);
  stmt.BindTextU(2, param2, paramIn);
  stmt.BindTextU(3, param3, paramIn);
  stmt.BindTextS(4, param4, paramOut);
  stmt.ExecutePrepared;                        // How do i get the returned integer from the function??

TRespond = class
  private
    fData: RawUTF8;
    fMessage: RawUTF8;
  published
    property Data: RawUTF8 read fData write fData;
    property Message: RawUTF8 read fMessagewrite fMessage;
  end;

function TService.GetById(id: RawUTF8): RawJSON;
var
  repository: TRepository;
  data: RawUTF8;
  respond: TRespond;
begin
  repository := TRepository.Create(fProps);
  data := repository.GetById(id);

  respond := TRespond.Create;
  respond.fData := data;
  respond.fMessage := 'some message';
  Result := ObjectToJson(respond);
end;