unit Xpire;

interface

uses
  SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls,
  Forms, Dialogs, DsgnIntf;

type
  TEnDeCodeEvent = procedure(Sender: TObject; encode: boolean; var s: string) of object;
  TExpireEvent = function(Sender: TObject): boolean of object;

  TXpire = class(TComponent)
  private
    { Private declarations }
    FDays: byte;
    FDate: TDateTime;
    FMessage: string;
    FText: TStringList;
    FPassword: string;
    FOnEnDeCode: TEnDeCodeEvent;
    FOnExpire: TExpireEvent;
    FOnCheckExpire: TExpireEvent;
    function getText: TStringList;
    procedure setText(sl: TStringList);
    procedure setPassword(pas: string);
    procedure setDate(d: TDateTime);
    procedure setDays(b: byte);
  protected
    { Protected declarations }
    procedure Loaded; override;
  public
    { Public declarations }
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
  published
    { Published declarations }
    property ExpDate: TDateTime read FDate write setDate;
    property ExpDays: byte read FDays write setDays;
    property ExpMessage: string read FMessage write FMessage stored true;
    property ExpText: TStringList read getText write setText stored false;
    property Password: string read FPassword write setPassword;
    property OnEnDeCode: TEnDeCodeEvent read FOnEnDeCode write FOnEnDeCode;
    property OnExpire: TExpireEvent read FOnExpire write FOnExpire;
    property OnCheckExpire: TExpireEvent read FOnCheckExpire write FOnCheckExpire;
  end;

  TRStringProperty = class( TStringProperty )
  public
        function GetAttributes: TPropertyAttributes; override;
  end;

procedure Register;

implementation

constructor TXpire.Create(AOwner: TComponent);
begin
     inherited Create(AOwner);
     FText:=TStringList.Create;
end;

destructor TXpire.Destroy;
begin
     FText.free;
     inherited Destroy;
end;

procedure TXpire.Loaded;
type
    Tpatch=packed record
                      id: string[10];
                      date: array[1..sizeof(TDateTime)] of byte;
               end;
const
     patch: Tpatch=(id:'HAL9000'+#97+#6+#12; date: (1,2,3,4,5,6,7,8));
var bo: boolean;
    s: string;
    b, pos: byte;
    searchrec: TSearchRec;
    i: integer;
    pc: PChar;
    d: TDateTime;
    bp: ^byte;
begin
     inherited Loaded;
     if csDesigning in Componentstate then exit;
     bp:=@d;
     bo:=true;
     for b:=1 to sizeof(patch.date) do begin
         bp^:=patch.date[b];
         bo:=bo and (patch.date[b]=b);
         inc(bp);
     end;
     if not(bo) then FDate:=d;
     if Assigned(FOnCheckExpire) then bo:=FOnCheckExpire(self)
     else begin
          i:=findfirst('*.*', faAnyFile, searchrec);
          try
            while i=0 do begin
                try
                   if (searchrec.time>0) and (filedatetodatetime(searchrec.time)>now) then break;
                except
                end;
                i:=findnext(searchrec);
            end;
          finally
            findclose(searchrec);
          end;
          if i<>0 then try
             pc:=@s;
             inc(pc);
             s[0]:=chr(GetSystemDirectory(pc, 250));
            i:=findfirst(s+'\*.*', faAnyFile, searchrec);
            while i=0 do begin
                try
                   if (searchrec.time>0) and (filedatetodatetime(searchrec.time)>now) then break;
                except
                end;
                i:=findnext(searchrec);
            end;
          finally
            findclose(searchrec);
          end;
          if i<>0 then try
             pc:=@s;
             inc(pc);
             s[0]:=chr(GetWindowsDirectory(pc, 250));
            i:=findfirst(s+'\*.*', faAnyFile, searchrec);
            while i=0 do begin
                try
                   if (searchrec.time>0) and (filedatetodatetime(searchrec.time)>now) then break;
                except
                end;
                i:=findnext(searchrec);
            end;
          finally
            findclose(searchrec);
          end;
          bo:=(i=0) or ((Now>ExpDate) and (ExpDate<>0));
     end;
     if not(bo) then exit;
     if Assigned(FOnExpire) then bo:=FOnExpire(self);
     if not(bo) then exit;
     s:=FMessage;
     pos:=0;
     if Assigned(FOnEnDecode) then FOnEnDecode(self, false, s)
     else if Password<>'' then for b:=1 to length(s) do begin
          pos:=(pos mod length(password))+1;
          s[b]:=chr(ord(s[b])xor ord(password[pos])xor (length(s)+length(password)));
     end;
     if s<>'' then begin
        MessageBeep(0);
        ShowMessage(s);
     end;
     halt;
end;

procedure TXpire.setDate(d: TDateTime);
begin
     FDate:=d;
     if csLoading in Componentstate then exit;
     FDays:=0;
end;

procedure TXpire.setDays(b: byte);
begin
     FDays:=b;
     if not(csDesigning in Componentstate) then exit;
     if b<>0 then FDate:=now+b;
end;

function TXpire.getText: TStringList;
var s: string;
    b, pos: byte;
begin
     Result:=FText;
     Result.Clear;
     s:=FMessage;
     pos:=0;
     if Assigned(FOnEnDecode) then FOnEnDecode(self, false, s)
     else if Password<>'' then for b:=1 to length(s) do begin
          pos:=(pos mod length(password))+1;
          s[b]:=chr(ord(s[b])xor ord(password[pos])xor (length(s)+length(password)));
     end;
     if s<>'' then Result.add(s);
end;

procedure TXpire.setText(sl: TStringList);
var s: string;
    b, pos: byte;
begin
     FText.Assign(sl);
     s:=''; pos:=0;
     for b:=1 to FText.count do s:=s+FText[b-1]+#13+#10;
     if s<>'' then delete(s, length(s)-1, 2);
     if Assigned(FOnEnDecode) then FOnEnDecode(self, true, s)
     else if Password<>'' then for b:=1 to length(s) do begin
          pos:=(pos mod length(password))+1;
          s[b]:=chr(ord(s[b])xor ord(password[pos])xor (length(s)+length(password)));
     end;
     FMessage:=s;
end;

procedure TXpire.setPassword(pas: string);
var s: string;
    b, pos: byte;
begin
     if csLoading in ComponentState then begin
        FPassword:=pas;
        exit;
     end;
     s:=FMessage;
     pos:=0;
     if Assigned(FOnEnDecode) then FOnEnDecode(self, false, s)
     else if Password<>'' then for b:=1 to length(s) do begin
          pos:=(pos mod length(password))+1;
          s[b]:=chr(ord(s[b])xor ord(password[pos])xor (length(s)+length(password)));
     end;
     FPassword:=pas; pos:=0;
     if Assigned(FOnEnDecode) then FOnEnDecode(self, true, s)
     else if Password<>'' then for b:=1 to length(s) do begin
          pos:=(pos mod length(password))+1;
          s[b]:=chr(ord(s[b])xor ord(password[pos])xor (length(s)+length(password)));
     end;
     FMessage:=s;
end;



function TRStringProperty.GetAttributes: TPropertyAttributes;
begin
     Result:=[paReadOnly];
end;

procedure Register;
begin
  RegisterComponents('Samples', [TXpire]);
  RegisterPropertyEditor(TypeInfo(string), TXpire, 'ExpMessage', TRStringProperty );
end;

end.