unit MethodAddrDemoUParser;

    { ****************************************************************** }
    {                                                                    }
    {   Delphi (6) unit  --   Illustrates how to acces an object's       }
    {   published methods, using their name (as string).                 }
    {   It illustrates too how to store pointers in variants.            }
    {                                                                    }
    {   Part II : The place where the published procs and functions to   }
    {             be called are declared and coded.                      }
    {                                                                    }
    {                  ----------------------------                      }
    {                                                                    }
    {   Copyright © 2005 by Olivier Touzot                               }
    {   (http://mapage.noos.fr/qnno/delphi_en.htm  -  qnno@noos.fr)      }
    {                                                                    }
    {   This code is provided "as is" without any guarantee. It can be   }
    {   freely used.                                                     }
    {                                                                    }
    { ****************************************************************** }

    // Access fonctions by their name (string). Remember that MethodAddress()
    // will return Nil if the method we try to access to has a visibility bellow
    // Published.

interface
  uses Dialogs{ShowMessage}, Classes{TStringList}, SysUtils{IntToStr},
       Variants{everywhere...}, StrUtils{LeftStr}, Grids{TStringGrid},
       DateUtils{DaySpan}, StdCtrls{TButton} ;


type
  // The record bellow will be used before calling a method : It is in charge of
  // splitting the string received into a command to be executed, and arguments
  // to pass it to.
  PParsedLine = ^TParsedLine;
  TParsedLine = Record
    lnMethodName: String;
    lnArguments:  Variant;
    lnIsValide:   Boolean;     // a line is "valid" if it doesn't start by '//'
  End;                         // (maybe not the better name...;-)  )

  // The record bellow will illustrate storing pointers in variants.
  // The procedures of this unit which deal with the stringGrid are obviously an
  // illustration of it too.
  TPointedRec = Record
    anInteger: Integer;
    aSender: TObject;
  End;
  // Pointer to above instances:
  PPointedRec = ^TPointedRec;

  // The adress returned by MethodAddress will be casted to the appropriate
  // type using the pointers bellow.
  // We could use one single type (and corresponding pointer) with both
  // procedures and functions, provided it may handle the most "extended" case
  // ie. the functions (their returned value). With procedures, we would
  // simply have to manage the result ourselves.
  // Having a dedicated wrapper for procedures and one for functions will
  // however be cleaner, so let's declare both.
  // As long as arguments and results of any kind are concerned, dealing only
  // with variants in this basic illustration was the easiest way of doing things.
  PProcMethod = ^TProcMethod;
  TProcMethod = procedure(V: Variant) of object;
  PFuncMethod = ^TFuncMethod;
  TFuncMethod = function (V: Variant): variant of object;

  // The class from which some functions will be accessible "by name" at runtime
  TLittleParser = Class
  Private
    function  ParseArgs     (aLine: String): Variant;
  public
    // here comes the intermediary procedure and function :
    procedure ExecProcByName(aMethodName: string; _args: Variant);
    Function  ExecFuncByName(aMethodName: string; _args: Variant): Variant;
    Function  ShowDuration  (Const duration: Double; intro: String): Variant;
    function  GetParsedLine (aLine: String): TParsedLine;
  Published
    constructor Create;
    destructor  Destroy; override;
    // Those published methods will be accessible "by name". Everything will
    // use variants, to simplify things (remember it's just a basic illustration)
    // -1- Those of the grid
    procedure LineSummary        (Const value: Variant);
    procedure TotalAccess        (Const value: Variant);
    procedure AverageAccess      (Const value: Variant);
    procedure Duration           (Const value: Variant);
    procedure TotalDuration      (Const value: Variant);
    procedure AverageDuration    (Const value: Variant);
    procedure UserShowMessage    (Const value: Variant);
    // -2- The memo ones
    function  AddIntegers        (Const value: Variant): Variant;
    function  AddStrings         (Const value: Variant): Variant;
    function  HandlePointerValues(Const value: Variant): Variant;
    // you can try to acces the grid's ones from the memo too, but obviously
    // most of them will fail, as long as there's no way to prepare the
    // argument waited by them from within the memo...
  end;


implementation


constructor TLittleParser.Create;
Begin inherited; End;

destructor TLittleParser.Destroy;
Begin Inherited; End;

function TLittleParser.ParseArgs(aLine: String): Variant;
var i, cutter,
    argsCount: integer;
Begin
  If (aLine = '') Then
  Begin
    result := Null;
    exit;
  End Else If (aLine[Length(aLine)] <> ')') Then
      Begin
        result := 'Missing final parenthesis...' ;
        Exit;
      End;
      
  If aLine[1] = '(' Then aLine := RightStr(aLine,Length(aLine)-1);
  aLine := LeftStr(aLine,Length(aLine)-1);
  // à partir de là, "déconcatenner" les args : sep = ","
  argsCount := 1;
  For i := 1 To Length(aLine) -1 Do
    If aLine[i] = ','
       Then inc(argsCount);

  If ArgsCount > 1 Then
  Begin
    result := VarArrayCreate([0,argsCount-1],varVariant);
    For i := 0 To ArgsCount -2 Do
    Begin
      cutter := Pos(',',aLine)-1;
      result[i] := LeftStr(aLine, cutter);
      aLine := RightStr(aLine, Length(aLine) - (cutter +1) );
    End;
    // finalization
    result[argsCount -1] := aLine;
  End Else result := aLine;
End;

function TLittleParser.GetParsedLine(aLine: String): TParsedLine;
Begin
  TRY
    result.lnIsValide := Not( Pos ('//',aLine) = 1 );
    If result.lnIsValide Then
    Begin
      result.lnMethodName := LeftStr(aLine, Pos('(',aLine)-1);
      result.lnArguments  := Self.ParseArgs( RightStr(aLine,
                                  Length(aLine) - Length(result.lnMethodName) ));
      result.lnIsValide   := Length(result.lnMethodName) > 0;
    End;
  EXCEPT
    result.lnIsValide := False;
  END;
End;


procedure TLittleParser.ExecProcByName(aMethodName: string; _args: Variant);
var
  PAddr: PProcMethod;
  M: TMethod;
begin
  TRY
  PAddr := MethodAddress(aMethodName);
  If PAddr <> Nil then
  Begin
    M.Code := PAddr;
    M.Data := Self;
    TProcMethod(M)(_args);
  End;
  EXCEPT;END;
end;


function TLittleParser.ExecFuncByName(aMethodName: string; _args: Variant): Variant;
var PAddr: PFuncMethod;
    M: TMethod;
begin
  result := '';
  TRY
  PAddr := MethodAddress(aMethodName);
  If PAddr <> Nil then
  Begin
    M.Code := PAddr;
    M.Data := Self;
    result := TFuncMethod(M)(_args);
  End Else result := Null;
  EXCEPT; END;
end;


// -----------------------------------------------------------------------------
// --- Storing pointers in variants
// -----------------------------------------------------------------------------

function TLittleParser.HandlePointerValues(Const value: Variant): Variant;
var v: Variant;
    i: Integer;
    s: String;
Begin
  // The variant received ("value") contains a pointer to a record of kind
  // TPointedRec;
  // To read this record we'll just need to cast our variant back to an integer,
  // then to a ^TPointedRec :
  i := StrToInt( varToStr( value ));

  // "i" now store our pointer, but doesn't know it yet
  // casting it to some type will do the trick. Eg: PPointedRec(i) casts it
  // to a pointer to a record of king TPointedRec.
  If PPointedRec(i).aSender is TButton
     Then s := TButton(PPointedRec(i).aSender).Caption
     Else s := '(Sender is not a button)';

  v := 'This function has been called '
     + VarToStr( PPointedRec(i).anInteger ) + ' times.'
     + #13#10
     + ' The caller is this time : '
     + s;
  result := v;
End;



// -----------------------------------------------------------------------------
// --- handling both memo lines and buttons
// -----------------------------------------------------------------------------

function TLittleParser.AddIntegers(Const value: Variant): Variant;
var i: Integer;
    v, vt, min, max: Variant;
Begin
  v := 0;
  If Not( VarIsArray( value )) then
  Begin
    result := 'Invalid arg( ' + value + ' ) : array wanted.';
    exit;
  End;
  TRY
    min := '0';
    max := '9';
    For i := 0 To VarArrayHighBound(value, 1) Do      // size of the array if any
    TRY
      If ( VarInRange( value[i] , min, max )) Then
      Begin
        vt := VarAsType(value[i], varInteger);        // casting to integers
        v  := v + vt;
      End;
    EXCEPT;END;
    result := v;
  EXCEPT
    result := -1;
  END;
End;


function TLittleParser.AddStrings(Const value: Variant): Variant;
var i: Integer;
    v: Variant;
Begin
  v := '';
  If Not( VarIsArray( value )) then
  Begin
    result := value;
    exit;
  End;
  TRY
    For i := 0 To VarArrayHighBound(value, 1) Do
        v := v + value[i];
    result := v;
  EXCEPT
    result := 'Failed to Concat';
  END;
End;


// -----------------------------------------------------------------------------
// --- The grid's popUp menu
// -----------------------------------------------------------------------------

procedure TLittleParser.LineSummary(Const value: Variant);
var v: Variant;
    i, aRow: Integer;
Begin
  If ( VarArrayHighBound( value, 1 ) < 2 ) then exit;

  // get back the pointer to the grid (still an integer)
  i := varAsType(value[0],varInteger);
  aRow := varAsType(value[2],varInteger);
  v := varArrayCreate([0,3],varOleStr);

  // The "integer" in arg[0] was a pointer to our grid. We can now acces it easy :
  v[0] := 'The event   "' + TStringGrid(i).Cells[0,aRow] + '"';
  v[1] := 'started :   '  + TStringGrid(i).Cells[1,aRow];
  v[2] := 'ended :     '  + TStringGrid(i).Cells[2,aRow];
  v[3] := 'and occured '  + TStringGrid(i).Cells[3,aRow] + ' times in this period.';

  // we've got a proc in charge of formatting and showing messages, let's use it.
  Self.UserShowMessage(v);
End;


procedure TLittleParser.TotalAccess(Const value: Variant);
var i,j,k, aCol: Integer;
Begin
  If ( VarArrayHighBound( value, 1 ) < 2 ) then exit;
  i := varAsType(value[0],varInteger);
  aCol := varAsType(value[1],varInteger);
  k := 0;
  For j := 1 To TStringGrid(i).RowCount -1 Do              // ignore row[0]
      k := k + StrToInt( TStringGrid(i).Cells[aCol,j] );
  Self.UserShowMessage('Total number of access observed : ' + IntToStr(k));
End;


procedure TLittleParser.AverageAccess(Const value: Variant);
var i, j, k, aCol: Integer;
Begin
  If ( VarArrayHighBound( value, 1 ) < 2 ) then exit;
  i := varAsType(value[0],varInteger);
  aCol := varAsType(value[1],varInteger);
  k := 0;
  For j := 1 To TStringGrid(i).RowCount -1 Do              // ignore row[0]
      k := k + StrToInt( TStringGrid(i).Cells[aCol,j] );
  Self.UserShowMessage('Average number of access observed : '
                      + FloatToStr(k / TStringGrid(i).RowCount-1 ));
End;


function TLittleParser.ShowDuration(Const duration: Double; intro: String): Variant;
var hh, mn, ss, ms: Word;
Begin
  DecodeTime(duration, hh, mn, ss, ms);
  Self.UserShowMessage( intro
                      + IntToStr(hh) + ':'
                      + IntToStr(mn) + ':'
                      + IntToStr(ss) );
End;
                 

procedure TLittleParser.Duration(Const value: Variant);
var i, aRow: Integer;
    evStart, evStop : TDateTime;
    duration : Double;
Begin
  If ( VarArrayHighBound( value, 1 ) < 2 ) then exit;
  i := varAsType(value[0],varInteger);
  aRow := varAsType(value[2],varInteger);
  evStart := StrToDateTime( TStringGrid(i).Cells[1,aRow] );
  evStop  := StrToDateTime( TStringGrid(i).Cells[2,aRow] );
  duration :=   DaySpan(evStop, evStart) ;
  Self.ShowDuration( duration, 'The event '
                      + TStringGrid(i).Cells[0,aRow]
                      + ' lasted (h:m:s): ' )
End;

procedure TLittleParser.TotalDuration(Const value: Variant);
var i,j: Integer;
    evStart, evStop : TDateTime;
    d : Array of Double;
Begin
  If ( VarArrayHighBound( value, 1 ) < 2 ) then exit;
  i := varAsType(value[0],varInteger);
  SetLength(d, TStringGrid(i).RowCount);
  For j := 1 To TStringGrid(i).RowCount -1 Do
  Begin
    evStart := StrToDateTime( TStringGrid(i).Cells[1,j] );
    evStop  := StrToDateTime( TStringGrid(i).Cells[2,j] );
    d[j]    := DaySpan(evStop, evStart) ;
  End;
  For j := 1 To Length(d)-1 Do                        // '-1': Remove the fixed row
      d[0] := d[0] + d[j];
  Self.ShowDuration( d[0], 'The whole observations lasted in total (h:m:s): ' )
End;

procedure TLittleParser.AverageDuration(Const value: Variant);
var i,j: Integer;
    evStart, evStop : TDateTime;
    d : Array of Double;
Begin
  If ( VarArrayHighBound( value, 1 ) < 2 ) then exit;
  i := varAsType(value[0],varInteger);
  SetLength(d, TStringGrid(i).RowCount);
  For j := 1 To TStringGrid(i).RowCount -1 Do
  Begin
    evStart := StrToDateTime( TStringGrid(i).Cells[1,j] );
    evStop  := StrToDateTime( TStringGrid(i).Cells[2,j] );
    d[j]    := DaySpan(evStop, evStart) ;
  End;
  For j := 1 To Length(d)-1 Do
      d[0] := d[0] + d[j];
  d[0] := d[0] / (TStringGrid(i).RowCount-1);         // '-1': Remove the fixed row
  Self.ShowDuration( d[0], 'These events lasts on average (h:m:s): ' )
End;


procedure TLittleParser.UserShowMessage(Const value: Variant);
var i: integer;
    s: String;
begin
  s := '';
  If varIsNull(value) Then s := 'No message to show...'
  Else If ( VarIsArray( value ) ) then
       Begin
         For i := 0 To VarArrayHighBound(value,1) Do
             s := s + value[i] + #13#10;
       End Else s := Value;
  // ShowMessage(s);
  MessageDlg(s, mtInformation, [mbOK], 0);
end;


end.