{ -----------------------------------------------------------------------
Tcl Scripting Language Components (Tslc)
Copyright (C) 1996-2002 William Byrne

This library is free software; you can redistribute it and/or
modify it under the terms of the GNU Lesser General Public
License as published by the Free Software Foundation; either
version 2.1 of the License, or (at your option) any later version.

This library is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
Lesser General Public License for more details.

You should have received a copy of the GNU Lesser General Public
License along with this library; if not, write to the Free Software
Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA

WilliamB@ByrneLitho.com
------------------------------------------------------------------------}
unit uPadLine;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  Tslc;

type
  TDataMod = class(TDataModule)
    TclCmdLine: TTcl;
    TclCommandLine: TTclCommand;
    TclCmdParamFile: TTclCmdParam;
    TclCmdLine_c: TTclCmdSwitch;
    TclCmdLine_s: TTclCmdSwitch;
    TclCmdLine_p: TTclCmdSwitch;
    TclCmdLine_h: TTclCmdSwitch;
    TclCmdLine_a: TTclCmdSwitch;
    TclCmdLine_r: TTclCmdSwitch;
    TclCmdLine_bde: TTclCmdSwitch;
    TclCmdLine_compress: TTclCmdSwitch;
    TclCmdLine_utility: TTclCmdSwitch;
    TclCmdLine_wait: TTclCmdSwitch;
    procedure TclCommandLineCommand(Sender: TTclCommand;
      var result: string; var success: Boolean);
    procedure TclCommandLinePrepare(Sender: TTclCommand; var result: string; var success: boolean);
    procedure TclCmdParamFileParam(Sender: TTclCmdParam; APos: Integer;
      AParam: string; var result: string; var success: Boolean);
    procedure TclCmdLine_cSwitch(Sender: TTclCmdSwitch; ASwitch: string;
      var result: string; var success: Boolean);
    procedure TclCmdLine_sSwitch(Sender: TTclCmdSwitch; ASwitch: string;
      var result: string; var success: Boolean);
    procedure TclCmdLine_pSwitch(Sender: TTclCmdSwitch; ASwitch: string;
      var result: string; var success: Boolean);
    procedure TclCmdLine_hSwitch(Sender: TTclCmdSwitch; ASwitch: string;
      var result: string; var success: Boolean);
    procedure TclCmdLine_aSwitch(Sender: TTclCmdSwitch; ASwitch: string;
      var result: string; var success: Boolean);
    procedure TclCmdLine_rSwitch(Sender: TTclCmdSwitch; ASwitch: string;
      var result: string; var success: Boolean);
    procedure TclCmdLine_bdeSwitch(Sender: TTclCmdSwitch; ASwitch: string;
      var result: string; var success: Boolean);
    procedure TclCmdLine_compressSwitch(Sender: TTclCmdSwitch;
      ASwitch: string; var result: string; var success: Boolean);
    procedure TclCmdLine_utilitySwitch(Sender: TTclCmdSwitch;
      ASwitch: string; var result: string; var success: Boolean);
    procedure TclCmdLine_waitSwitch(Sender: TTclCmdSwitch; ASwitch: string;
      var result: string; var success: Boolean);
  private
    { Private declarations }
    FLoadBDE, FLoadCompress, FLoadUtility, FLoadWait: boolean;
  public
    { Public declarations }
  end;

procedure ParseCmdLine(var LoadBDE: boolean; var LoadCompress: boolean;
	var LoadUtility: boolean; var LoadWait: boolean); // Throws ETclError
procedure VerifyAccess(password: string); // Throws ETclError

var
    EvalSilent, EvalClose, EvalHexword: boolean;
    EvalFile, EvalPassword, AccessPassword: string;

implementation
uses TslcUtil, TslcDes, TslcKey;
{$R *.DFM}


procedure ParseCmdLine(var LoadBDE: boolean; var LoadCompress: boolean;
	var LoadUtility: boolean; var LoadWait: boolean);
var
	list: TStrings;
    x: integer;
    retVal: string;
begin
	if ParamCount < 1 then
    	exit;
    with TDataMod.Create(nil) do
    try
		FLoadBDE := LoadBDE;
        FLoadCompress := LoadCompress;
        FLoadUtility := LoadUtility;
        FLoadWait := LoadWait;
	    list := TStringList.Create;
	    try
			for x:= 1 to ParamCount do
	        	list.Add(ParamStr(x));
	        if not TclCommandLine.EmulateList( retVal, list) then
            	TclError(retVal);
	    finally
	    	list.Free;
	    end;
        LoadBDE := FLoadBDE;
        LoadCompress := FLoadCompress;
        LoadUtility := FLoadUtility;
        LoadWait := FLoadWait;
    finally
    	Free;
    end;
end;

procedure VerifyAccess(password: string);
var
	keyBuf: TDESKey;
begin
	if StaticDecrypt(TslcGetSecondaryKey, keyBuf, sizeof(keyBuf)) <> 0 then
    	TclError('A Password Error Occurred');
    if password <> keyBuf then
    	TclError('Invalid Password');
end;

procedure TDataMod.TclCommandLinePrepare(Sender: TTclCommand; var result: string; var success: boolean);
begin
    EvalClose := False;
    EvalFile := '';
    EvalSilent := False;
    EvalPassword := '';
    EvalHexword := False;
end;

procedure TDataMod.TclCmdLine_cSwitch(Sender: TTclCmdSwitch;
  ASwitch: string; var result: string; var success: Boolean);
begin
	EvalClose := TslcStrTruth(Sender.SplitDef(ASwitch, '+'));
end;

procedure TDataMod.TclCmdLine_sSwitch(Sender: TTclCmdSwitch;
  ASwitch: string; var result: string; var success: Boolean);
begin
	EvalSilent := TslcStrTruth(Sender.SplitDef(ASwitch, '+'));
end;

procedure TDataMod.TclCmdLine_pSwitch(Sender: TTclCmdSwitch;
  ASwitch: string; var result: string; var success: Boolean);
begin
	EvalPassword := Sender.Split(ASwitch);
end;

procedure TDataMod.TclCmdLine_hSwitch(Sender: TTclCmdSwitch;
  ASwitch: string; var result: string; var success: Boolean);
begin
	EvalHexword := TslcStrTruth(Sender.SplitDef(ASwitch, '+'));
end;

procedure TDataMod.TclCmdLine_aSwitch(Sender: TTclCmdSwitch;
  ASwitch: string; var result: string; var success: Boolean);
begin
	AccessPassword := Sender.Split(ASwitch);
end;

procedure TDataMod.TclCmdParamFileParam(Sender: TTclCmdParam; APos: Integer;
  AParam: string; var result: string; var success: Boolean);
begin
	EvalFile := AParam;
end;

procedure TDataMod.TclCommandLineCommand(Sender: TTclCommand;
  var result: string; var success: Boolean);
var
	keyBuf: TDESKey;
begin
	// TclError('...') for testing

   	if (EvalPassword <> '') and EvalHexword then
	begin
		if StaticDecrypt(pChar(EvalPassword), keyBuf, sizeof(keyBuf)) <> 0 then
        	TclError('A Password Error Occurred');
        EvalPassword := keyBuf;
    end;

	if UpperCase(ExtractFileExt(EvalFile)) = '.TZP' then
    begin
		EvalSilent := True;
        EvalClose := True;
		if EvalPassword = '' then
        begin
			if StaticDecrypt(TslcGetSecondaryKey, keyBuf, sizeof(keyBuf)) <> 0 then
    	    	TclError('A Password Error Occurred');
        	EvalPassword := keyBuf;
        end;
    end;

end;

procedure TDataMod.TclCmdLine_rSwitch(Sender: TTclCmdSwitch;
  ASwitch: string; var result: string; var success: Boolean);
const
	cMaxBuf = 255;
    cType = '.tzp';
    cTypeOpen: pChar = 'TslcScript';
    cDefaultIcon: pChar = 'DefaultIcon';
    cShellOpenCommand: pChar = 'shell\open\command';
var
	hk, hsk, hssk: HKey;
    buf: array[0..cMaxBuf] of char;
    regType, len, disp: DWORD;
    app: string;
begin
	app := Application.ExeName;
	if RegOpenKeyEx(HKEY_CLASSES_ROOT, nil, 0, KEY_WRITE, hk) <> ERROR_SUCCESS then
    	TclError('Unable to open registry');
    try
		if RegCreateKeyEx(hk, cType, 0, nil, REG_OPTION_NON_VOLATILE, KEY_WRITE, nil, hsk, @disp) <> ERROR_SUCCESS then
        	TclError('Unable to create class key');
        try
        	if RegSetValueEx(hsk, nil, 0, REG_SZ, cTypeOpen, sizeof(cTypeOpen)) <> ERROR_SUCCESS then
            	TclError('Unable to create default value');
        finally
            RegCloseKey(hsk);
        end;
		if RegCreateKeyEx(hk, cTypeOpen, 0, nil, REG_OPTION_NON_VOLATILE, KEY_WRITE, nil, hsk, @disp) <> ERROR_SUCCESS then
        	TclError('Unable to create class key');
        try
			if RegCreateKeyEx(hsk, cDefaultIcon, 0, nil, REG_OPTION_NON_VOLATILE, KEY_WRITE, nil, hssk, @disp) <> ERROR_SUCCESS then
    	    	TclError('Unable to create class key');
			try
	        	if RegSetValueEx(hssk, nil, 0, REG_SZ, pChar(app), strlen(pChar(app))) <> ERROR_SUCCESS then
			       	TclError('Unable to write registry value');
            finally
            	RegCloseKey(hssk);
            end;
			if RegCreateKeyEx(hsk, cShellOpenCommand, 0, nil, REG_OPTION_NON_VOLATILE, KEY_WRITE, nil, hssk, @disp) <> ERROR_SUCCESS then
    	    	TclError('Unable to create class key');
			try
               	app := app + ' "%1"';
	        	if RegSetValueEx(hssk, nil, 0, REG_SZ, pChar(app), strlen(pChar(app))) <> ERROR_SUCCESS then
			       	TclError('Unable to write registry value');
            finally
            	RegCloseKey(hssk);
            end;
        finally
            RegCloseKey(hsk);
        end;
    finally
        RegCloseKey(hk);
    end;
	TclError('Application Registered');
end;

procedure TDataMod.TclCmdLine_bdeSwitch(Sender: TTclCmdSwitch;
  ASwitch: string; var result: string; var success: Boolean);
begin
	FLoadBDE := TslcStrTruth(Sender.SplitDef(ASwitch, '+'));
end;

procedure TDataMod.TclCmdLine_compressSwitch(Sender: TTclCmdSwitch;
  ASwitch: string; var result: string; var success: Boolean);
begin
	FLoadCompress := TslcStrTruth(Sender.SplitDef(ASwitch, '+'));
end;

procedure TDataMod.TclCmdLine_utilitySwitch(Sender: TTclCmdSwitch;
  ASwitch: string; var result: string; var success: Boolean);
begin
	FLoadUtility := TslcStrTruth(Sender.SplitDef(ASwitch, '+'));
end;

procedure TDataMod.TclCmdLine_waitSwitch(Sender: TTclCmdSwitch;
  ASwitch: string; var result: string; var success: Boolean);
begin
	FLoadWait := TslcStrTruth(Sender.SplitDef(ASwitch, '+'));
end;

initialization
	SetStaticKey(TslcGetStaticKey, 0); // Created using script: StaticKey Gen <?secretkey?>

end.

