Chip 1998 March/Chip_1998-03_cd.bin/zkuste/delphi/WhiteAnts/CMPNAMES.ZIP/CMPNAMES.PAS

Pascal/Delphi Source File | 1997-02-14 | 21.9 KB | 744 lines

{
+----------------------------------------------------------------------------+
|                                      ⌐  ⌐                                  |
|                                    ⌐⌐ ⌐ ⌐ ⌐                                |
|                                 ⌐⌐⌐ ⌐   ⌐  ⌐                               |
|                                 ⌐⌐    ⌐ ⌐   ⌐                              |
|                  ⌐             ⌐⌐     ⌐  ⌐                                 |
|                 ⌐ ⌐            ⌐⌐⌐    ⌐⌐  ⌐                                |
|             ⌐⌐  ⌐  ⌐      ⌐⌐⌐⌐⌐⌐⌐⌐⌐⌐  ⌐                                    |
|            ⌐  ⌐⌐  ⌐⌐      ⌐⌐⌐⌐⌐⌐⌐⌐⌐⌐⌐⌐⌐⌐⌐                                  |
|            ⌐ ⌐⌐⌐ ⌐⌐⌐⌐⌐⌐ ⌐⌐⌐ ⌐   ⌐⌐⌐⌐⌐⌐⌐⌐                                   |
|           ⌐ ⌐⌐ ⌐⌐⌐⌐⌐⌐⌐⌐⌐⌐⌐⌐ ⌐   ⌐⌐⌐⌐⌐⌐⌐⌐⌐⌐      Copyright ⌐ 1996-1997 by:  |
|           ⌐ ⌐⌐⌐⌐⌐⌐ ⌐⌐⌐⌐⌐⌐⌐⌐⌐⌐⌐  ⌐ ⌐⌐⌐⌐⌐ ⌐⌐                                 |
|          ⌐ ⌐⌐⌐⌐⌐⌐⌐   ⌐⌐⌐⌐⌐ ⌐⌐⌐⌐    ⌐⌐ ⌐⌐ ⌐      WHITE ANTS SYSTEMHOUSE BV  |
|         ⌐  ⌐⌐⌐⌐⌐⌐⌐ ⌐⌐⌐ ⌐⌐⌐ ⌐⌐ ⌐       ⌐⌐⌐⌐      Geleen 12                  |
|         ⌐ ⌐⌐⌐⌐⌐⌐⌐    ⌐   ⌐⌐   ⌐⌐⌐       ⌐       8032 GB Zwolle             |
|           ⌐⌐⌐⌐⌐⌐     ⌐            ⌐ ⌐           Netherlands                |
|      ⌐⌐⌐  ⌐⌐⌐⌐⌐      ⌐     ⌐⌐     ⌐  ⌐                                     |
|            ⌐⌐       ⌐              ⌐  ⌐⌐⌐ ⌐     Tel. [phone]      |
|      ⌐              ⌐              ⌐            Fax. [phone]      |
|      ⌐             ⌐               ⌐⌐                                      |
|    ⌐              ⌐                  ⌐⌐         www.whiteants.com          |
|  ⌐⌐              ⌐                     ⌐ ⌐      [e-mail]      |
|                 ⌐                                                          |
+----------------------------------------------------------------------------+
  file     : CmpNames
  version  : 1.01
  comment  :
  date     : 14-02-1997
  time     : 13:57:59
  author   : G.Beuze, R.Post
  compiler : Delphi 1.0
+----------------------------------------------------------------------------+
| DISCLAIMER:                                                                |
| THIS SOURCE IS FREEWARE. YOU ARE ALLOWED TO USE IT IN YOUR OWN PROJECTS    |
| WITHOUT ANY RESTRICTIONS, BUT YOU ARE NOT ALLOWED TO SELL IT IN ANY WAY.   |
| THERE IS NO WARRANTY AT ALL - YOU USE IT ON YOUR OWN RISC. WHITE ANTS DOES |
| NOT ASSUME ANY RESPONSIBILITY FOR ANY DAMAGE OR ANY LOOSE OF TIME OR MONEY |
| DUE THE USE OF ANY PART OF THIS SOURCE CODE.                               |
+----------------------------------------------------------------------------+

  Description:
This unit contains the TRenamer class which is used to apply
naming convention to components dropped on a form during design time.
TRenamer uses the classes TNameRule and TNameRuleList which are also
declared in this unit.

Although this unit is only active when installed in the component library
it is not visible in the VCL since there are no components registered
from within this unit.

The name rules are read from the file NAMERULE.INI which should be placed in the
COMPLIB.DCL directory. A log file NAMERULE.LOG is written to the same directory
to inform you of recognized rules, the default rule and components to which
they apply.

The idea of applying naming conventions and some basic mechanisms were taken
from Ray Lischners book "Secrets of Delhi 2.0". We at White Ants basically added
the designer wrapper interface and the ini-files.

Caution:
- Do not instantiate a TRenamer class yourself by calling TRenamer.Create.
- TRenamer grabs the Delphi executable's Screen.OnActiveFormChange.
- TRenamer interferes with delphi's Form designer. Be cautions to install
  this unit if you have any other units installed in the VCL which
  also interact with or are depending on Delphi's FormDesigner. You''ll get a
  warning if this unit detects such an error. This should   normally not be the
  case, at White Ants we enjoy working (troublefree) using this unit.
}

unit CmpNames;
{MMWIN:ENDEXPAND}

interface

function CheckRule(const Rule: string): Integer;

procedure Register;

implementation

uses
  WinTypes, WinProcs, SysUtils, Classes, Controls, Forms, TypInfo, ExtCtrls,
  DsgnIntf, LibMain, IniFiles, Dialogs,                 { standard VCL units }
  DsgnWrap, Containr, StrUtils, FileUtil, TextStrm;     { WAS units }

type
  TNameRule = class (TObject)
  private
    FName: PString;
    FRule: PString;
  protected
    function GetName: string;
    function GetRule: string;
    procedure SetName(const Value: String);
    procedure SetRule(const Value: String);
  public
    constructor Create(const aName, aRule: string);
    destructor Destroy; override;
    property Name: string read GetName write SetName;
    property Rule: string read GetRule write SetRule;
  end;

  TNameRuleList = class (TCollection)
  private
    FDefaultRule: string;
  protected
    function GetNameRules(Index: Integer): TNameRule;
  public
    constructor Create;
    destructor Destroy; override;
    function Compare(Key1, Key2: Pointer): Integer; override;
    function FindRule(Component: TComponent): string;
    function KeyOf(Instance: Pointer): Pointer; override;
    procedure LoadFromFile(const FileName: string);
    property DefaultRule: string read FDefaultRule write FDefaultRule;
    property NameRules[Index: Integer]: TNameRule read GetNameRules;
  end;

  TRenamer = class (TComponent)
  private
    FActiveForm: TForm;
    FDesigner: TDesignerDecorator;
    FFileName: string;
    FList: TList;
    FPrevActiveFormChange: TNotifyEvent;
    FRules: TNameRuleList;
    FScreenHooked: Boolean;
    FTimer: TTimer;
    procedure Log;
    procedure UpdateTimer;
  protected
    procedure ActiveFormChange(Sender: TObject);
    function ApplyRule(Component: TComponent; const Rule: string): string;
    procedure DesignerNotification(Sender: TObject; AComponent: TComponent; Operation:
        TOperation);
    procedure DesignerUnhookError(Sender: TObject);
    procedure DesignerValidateRename(Sender: TObject; AComponent: TComponent; const
        CurName, NewName: string);
    function FilterName(const Orig: string): string;
    function GetPropertyValue(Component: TComponent; AName: String): string;
    function IsreservedWord(const AName: string): Boolean;
    function RemoveTag(const Fmt: string): string;
    procedure SetActiveForm(Value: TForm);
    procedure SetFileName(const Value: String);
    procedure SetPropValue(aObject: TObject; const aProp, aValue: string);
    function TestName(Component: TComponent; const AName: string): Boolean;
    procedure TimerTick(Sender: TObject);
    function UniqueName(Component: TComponent): string;
    procedure UnwireDesigner;
    procedure UpdateActiveForm;
    procedure WireDesigner;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    property ActiveForm: TForm read FActiveForm write SetActiveForm;
    property Designer: TDesignerDecorator read FDesigner;
    property Rules: TNameRuleList read FRules;
  published
    property FileName: string read FFileName write SetFileName;
  end;


const
  FRenamer: TRenamer = nil;
  RuleFilename = 'NameRule.ini';
  LogFileName = 'NameRule.Log';

{ Some reserved words (not an extensive list, see Delphi's language guides }
  MAX_RES_WORD = 24;
  SomeResWords : array[1..MAX_RES_WORD] of PChar =
    ('array',    'case',     'class',    'const',    'constructor', 'destructor',
     'file',     'function', 'inline',   'interface','label',       'library',
     'object',   'procedure','program',  'property', 'record',      'set',
     'string',   'then',     'threadvar','type',     'unit',        'with');

procedure Register;
begin
  FRenamer := TRenamer.Create(nil);
end;

const
  AlphaNumerics = ['a'..'z', 'A'..'Z', '_', '0'..'9'];
  Letters       = ['a'..'z', 'A'..'Z', '_'];

function CheckRule(const Rule: string): Integer;
begin
  { Result returns the position at which an error was found,
    or 0 if the rule is OK }
  Result := 1;
  if (Length(Rule) <= 0) or not (Rule[1] in (Letters + ['%'])) then
    Exit;
  while Result <= Length(Rule) do
  begin
    if Rule[Result] = '%' then
      begin
        if Result = Length(Rule) then
          Exit;
        if not (Rule[Result+1] in ['n', 'N', 't', 'T']) then
          Exit;
        Inc(Result);
      end
      else if not (Rule[Result] in AlphaNumerics) then
        Exit;
    Inc(Result);
  end;
  Result := 0;
end;


{
*************************************** TNameRule ****************************************
}
constructor TNameRule.Create(const aName, aRule: string);
begin
  inherited Create;
  SetName(aName);
  SetRule(aRule);
end;

destructor TNameRule.Destroy;
begin
  DisposeStr(FName);
  DisposeStr(FRule);
  inherited Destroy;
end;

function TNameRule.GetName: string;
begin
  Result := StringValue(FName);
end;

function TNameRule.GetRule: string;
begin
  Result := StringValue(FRule);
end;

procedure TNameRule.SetName(const Value: String);
begin
  AssignStr(FName, Value);
end;

procedure TNameRule.SetRule(const Value: String);
begin
  AssignStr(FRule, Value);
end;

{
************************************* TNameRuleList **************************************
}
constructor TNameRuleList.Create;
begin
  inherited Create;
  CanSort := True;
  OwnesItems := True;
  Sorted := True;
  Duplicates := CONTAINR.dupAccept;
  DefaultRule := '%t%N';
end;

destructor TNameRuleList.Destroy;
begin
  inherited Destroy;
end;

function TNameRuleList.Compare(Key1, Key2: Pointer): Integer;
begin
  Result := CompareText(StringValue(PString(Key1)), StringValue(PString(Key2)));
end;

function TNameRuleList.FindRule(Component: TComponent): string;
var
  Index: Integer;
  Name: string;
begin
  Name := Component.ClassName;
  if FindKey(@Name, Index) then
    Result := NameRules[Index].Rule
  else
    Result := DefaultRule;
end;

function TNameRuleList.GetNameRules(Index: Integer): TNameRule;
begin
  Result := TNameRule(Items[Index]);
end;

function TNameRuleList.KeyOf(Instance: Pointer): Pointer;
begin
  Result := TNameRule(Instance).FName;
end;

procedure TNameRuleList.LoadFromFile(const FileName: string);
var
  IniFile: TIniFile;
  I: Integer;
  FSection: TStringList;
  procedure EntryToRule(Entry: string);
  var P: Integer;
      Rule, Name: String;
  begin
    Entry := DelWhiteSpace(Entry);
    P := Pos('=', Entry);
    if P > 0 then
    begin
      Rule := Copy(Entry, P + 1, 255);
      Name := Copy(Entry, 1, P - 1);
      if IsValidIdent(Name) and (CheckRule(Rule) = 0) then
        if CompareText( 'Default', Name) = 0 then
          DefaultRule := Rule
        else
          Add(TNameRule.Create(Name, Rule));
    end;
  end;
begin
  Clear;
  if FileExists (FileName) then
  begin
    IniFile := TIniFile.Create(FileName);
    FSection := TStringList.Create;
    try
      IniFile.ReadSectionValues('NameRules', FSection);
      for I := 0 to FSection.Count -1 do
        EntryToRule(FSection[I]);
    finally
      FSection.Free;
      IniFile.Free;
    end;
  end;
end;

{
**************************************** TRenamer ****************************************
}
constructor TRenamer.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  FDesigner := TDesignerDecorator.Create;
  FList := TList.Create;
  FRules := TNameRuleList.Create;
  FTimer := TTimer.Create(Self);
  WireDesigner;
  FileName := CommandPath + RuleFileName;
  FTimer.OnTimer := TimerTick;
  FTimer.Interval := 55;
  { Use the first tick to log the current rules }
  FTimer.Enabled := True;
  { hook on to the screen }
  FPrevActiveFormChange := Screen.OnActiveFormChange;
  Screen.OnActiveFormChange := ActiveFormChange;
  FScreenHooked := True;
end;

destructor TRenamer.Destroy;
begin
  try
    if FScreenHooked then
      Screen.OnActiveFormChange := FPrevActiveFormChange;
  except
    { Screen alreasy gone, therefore no need to unhook and we can ignore EGPFaults }
    on EGPFault do;
  end;
  FTimer.Enabled := False;
  FList.Clear;
  UnwireDesigner;
  FDesigner.Free;
  FList.Free;
  FRules.Free;
  inherited Destroy;
end;

procedure TRenamer.ActiveFormChange(Sender: TObject);
begin
  if Assigned(FPrevActiveFormChange) then FPrevActiveFormChange(Sender);
  UpdateActiveForm;
end;

function TRenamer.ApplyRule(Component: TComponent; const Rule: string): string;
var
  Optional: Boolean;
  Fmt: string;
  I, J: Integer;
begin
  Optional := False;
  Fmt := '';
  Result := '';
  I := 1;
  while I < Length(Rule) do
  begin
    if (Rule[I] <> '%') or (I = Length(Rule)) then
      AppendStr(Fmt, Rule[I])
    else
    begin
      Inc(I);
      case Rule[I] of
      'n': { unique number }
        AppendStr(Fmt, '%d');
      'N': { optional unique number }
        begin
          AppendStr(Fmt, '%d');
          Optional := True;
        end;
      't': { type name without the leading T }
        if Component.ClassName[1] in ['t', 'T'] then
          AppendStr(Fmt, Copy(Component.ClassName, 2, 255))
        else
          AppendStr(Fmt, Component.ClassName);
      'T': { complete type name }
        AppendStr(Fmt, Component.ClassName);
      else
        AppendStr(Fmt, '%' + Rule[I]);
      end;
    end;
    Inc(I);
  end; { while }

  { Remove all invalid characters from the name. }
  Fmt := FilterName(Fmt);

  { If there is no %d in the format, then append it, but mark it as optional. }
  if Pos('%d', Fmt) = 0 then
  begin
    AppendStr(Fmt, '%d');
    Optional := True;
  end;

  { Now try to generate a unique name. If the %d is optional, first try
    without it. Then try successive numbers, starting with 1, until a
    unique name is found. If there is no way to create a unique name,
    then raise an exception. ( Imagine 32K components on a form! ) }
  if Optional then
  begin
    Result := RemoveTag(Fmt);
    if TestName(Component, Result) then
      Exit;
  end;

  for I := 1 to High(Integer) do
  begin
    Result := Format(Fmt, [I]);
    if TestName(Component, Result) then
      Exit;
  end;

  raise Exception.CreateFmt('Unable to apply naming rules for %s', [Component.ClassName]);
end;

procedure TRenamer.DesignerNotification(Sender: TObject; AComponent: TComponent;
    Operation: TOperation);
begin
  if Operation = opRemove then
  begin
    FList.Remove(AComponent);
    UpdateTimer;
  end;
end;

procedure TRenamer.DesignerUnhookError(Sender: TObject);
begin
  Application.MessageBox(
     'Name Rule designer unhook error. Remove the unit CMPNAMES fomr your VCL',
      nil, MB_ICONHAND or MB_OK);
end;

procedure TRenamer.DesignerValidateRename(Sender: TObject; AComponent: TComponent; const
    CurName, NewName: string);
  function StandardName: Boolean;
  begin
    Result := (CompareText(Copy(AComponent.ClassName, 2, 255), GetTemplate(NewName)) = 0);
  end;
begin
  { do NOT trigger on insertion, instead trigger on the IDE renaming a component
    which results in a ValidateRename call }
  if (Length(CurName) = 0) and (Length(NewName) > 0) and StandardName then
  { trigger }
    if FList.IndexOf(AComponent) = -1 then
    begin
      FList.Add(AComponent);
      UpdateTimer;
    end;
end;

function TRenamer.FilterName(const Orig: string): string;
var
  I: Integer;
begin
  Result := '';
  for I := 1 to Length(Orig) do
    if (Orig[I] = '%') and (I < Length(Orig)) and (Orig[I+1] = 'd') then
      AppendStr(Result, Orig[I])
    else
      if Orig[I] in AlphaNumerics then AppendStr(Result, Orig[I]);
  if (Length(Result) = 0) or not (Result[1] in Letters) then
    Result := '_' + Result;
end;

function TRenamer.GetPropertyValue(Component: TComponent; AName: String): string;
var
  PropInfo: PPropInfo;
begin
  Result := '';
  PropInfo := GetPropInfo(Component.ClassInfo, AName);
  if PropInfo = nil then Exit;
  with PropInfo^ do
    case PropType^.Kind of
    {$IFDEF WIN32}
      tkLString,
    {$ENDIF}
      tkString:
        Result := GetStrProp(Component, PropInfo);
      tkInteger:
        Result := IntToStr(GetOrdProp(Component, PropInfo));
      tkChar:
        Result := Chr(GetOrdProp(Component, PropInfo));
      else
        Exit;
      end;
end;

function TRenamer.IsreservedWord(const AName: string): Boolean;
var
  Ident: array[0..255] of Char;
  I: Integer;
begin
  StrPCopy(Ident, LowerCase(AName));
  for I := 1 to MAX_RES_WORD do
    if StrComp(Ident, SomeResWords[I]) = 0 then
    begin
      Result := True;
      Exit;
    end;
  Result := False;
end;

procedure TRenamer.Log;
var
  T: TTextFile;
  ModuleNum, CompNum: Integer;
  CompName: String[63];
  Index: Integer;
  Ruled, Unruled: TStringList;
  const IsLogged: Boolean = False;
begin
  if IsLogged then Exit;
  IsLogged := True;
  try
    try
      T := TTextFile.Create(CommandPath + LogFileName, tmCreate);
      try
        T.WriteLine('[Default rule]');
        T.WriteLnFmt('Default=%s', [FRules.DefaultRule]);
        T.Newline;

        Ruled := TStringList.Create;
        Unruled := TStringList.Create;
        try
          Ruled.Sorted := True;
          Unruled.Sorted := True;

          with AppBuilder.GetToolServices do
            for ModuleNum := 0 to GetModuleCount - 1 do
              for CompNum := 0 to GetComponentCount(ModuleNum) - 1 do
              begin
                CompName := GetComponentName(ModuleNum, CompNum);
                if FRules.FindKey(@CompName, Index) then
                  Ruled.Add(Format('%s=%s', [CompName, FRules.NameRules[Index].Rule]))
                else
                  Unruled.Add(Format('%s=%s', [CompName, FRules.DefaultRule]));
              end;

          T.WriteLine('[Components to which a name rule applies]');
          for Index := 0 to Ruled.Count-1 do T.WriteLine(Ruled[Index]);

          T.NewLine;

          T.WriteLine('[Components to which the default name rule applies]');
          for Index := 0 to Unruled.Count-1 do T.WriteLine(Unruled[Index]);

        finally
          Ruled.Free;
          Unruled.Free;
        end;
      finally
        T.Free;
      end;
    except
      Application.MessageBox('Error logging name rules', nil, MB_ICONHAND or MB_OK);
    end;
  finally
    UpdateTimer;
  end;
end;

function TRenamer.RemoveTag(const Fmt: string): string;
var
  Index: Integer;
begin
  Index := Pos('%d', Fmt);
  if Index = 0 then
    Result := Fmt
  else
    Result := Copy(Fmt, 1, Index - 1) + Copy(Fmt, Index + 2, 255);
end;

procedure TRenamer.SetActiveForm(Value: TForm);
var
  Str: string;
begin
  if Value <> FActiveForm then
  begin
    { do not affect components any more: clear list }
    FList.Clear;
    FTimer.Enabled := False;
    FActiveForm := Value;
    Designer.Hook(FActiveForm);
  end;
end;

procedure TRenamer.SetFileName(const Value: String);
begin
  if FFileName <> Value then
  begin
    FFileName := Value;
    FRules.LoadFromFile(FFileName);
  end;
end;

procedure TRenamer.SetPropValue(aObject: TObject; const aProp, aValue: string);
var
  PropInfo: PPropInfo;
begin
  PropInfo := GetPropInfo(aObject.ClassInfo, aProp);
  if PropInfo <> nil then
    SetStrProp(aObject, PropInfo, aValue);
end;

function TRenamer.TestName(Component: TComponent; const AName: string): Boolean;
var
  Cmp: TComponent;
begin
  if Component.Owner = nil then
    Cmp := nil
  else
    Cmp := Component.Owner.FindComponent(AName);
  Result := IsValidIdent(AName) and not IsReservedWord(AName) and
            ((Cmp = nil) or (Cmp = Component));
end;

procedure TRenamer.TimerTick(Sender: TObject);
var
  Modified: Boolean;
  I: Integer;
  NewName: string;
  Comp: TComponent;
  DefaultCaption: string;
begin
  FTimer.Enabled := False;
  Log;
  Modified := False;
  try
    for I := 0 to FList.Count - 1 do
    begin
      NewName := UniqueName(FList[I]);
      try
        if Length(NewName) > 0 then
        begin
          Comp := TComponent(FList[I]);
          Comp.Name := NewName;
          if (Comp is TControl) and (csSetCaption in TControl(Comp).ControlStyle) then
          begin
            DefaultCaption := Comp.ClassName;
            if DefaultCaption[1] in ['t', 'T'] then
              Delete(DefaultCaption, 1, 1);
            if CompareText(GetTemplate(GetPropertyValue(Comp, 'Caption')),
                           DefaultCaption) = 0 then
            begin
              SetPropValue(TObject(FList[I]), 'Caption', NewName);
              SetPropValue(TObject(FList[I]), 'Text', NewName);
            end;
          end;
          Modified := True;
        end;
      finally
        FList[I] := nil;
      end;
    end;
  finally
    FList.Pack;
    if Modified then FDesigner.Modified;
    UpdateTimer;
  end;
end;

function TRenamer.UniqueName(Component: TComponent): string;
begin
  Result := FRules.FindRule( Component);
  if Length( Result) > 0 then
    Result := ApplyRule( Component, Result);
end;

procedure TRenamer.UnwireDesigner;
begin
  FDesigner.OnNotification := nil;
  FDesigner.OnValidateRename := nil;
  FDesigner.OnUnhookError := nil;
end;

procedure TRenamer.UpdateActiveForm;
var
  F: TForm;
begin
  F := Screen.ActiveForm;
  if Assigned(F) and (csDesigning in F.ComponentState)  then
    ActiveForm := F
  else
    ActiveForm := nil;
end;

procedure TRenamer.UpdateTimer;
begin
  FTimer.Enabled := FList.Count > 0;
end;

procedure TRenamer.WireDesigner;
begin
  FDesigner.OnNotification := DesignerNotification;
  FDesigner.OnValidateRename := DesignerValidateRename;
  FDesigner.OnUnhookError := DesignerUnhookError;
end;


procedure Terminate; far;
begin
  FRenamer.Free;
end;

initialization
{
  RegisterStreamable(TNameRuleList);
}
  AddExitProc(Terminate);
end.