C++博客-GCC/GNU/Linux Delphi/Window Java/Anywhere-随笔分类-Delphi

昨天玩delphi线程,找到一篇文章,强烈推荐大家看看,tthread代码分析

Khan's Notebook — Tue, 21 Nov 2006 03:46:00 GMT

Delphi中的线程类

转贴于华夏黑客同盟 http://www.77169.org

Delphi中有一个线程类TThread是用来实现多线程编程的，这个绝大多数Delphi书藉都有说到，但基本上都是对

TThread类的几个成员作一简单介绍，再说明一下Execute的实现和Synchronize的用法就完了。然而这并不是多线程编
程的全部，我写此文的目的在于对此作一个补充。

线程本质上是进程中一段并发运行的代码。一个进程至少有一个线程，即所谓的主线程。同时还可以有多个子线程。
当一个进程中用到超过一个线程时，就是所谓的“多线程”。
那么这个所谓的“一段代码”是如何定义的呢？其实就是一个函数或过程（对Delphi而言）。
如果用Windows API来创建线程的话，是通过一个叫做CreateThread的API函数来实现的，它的定义为：
HANDLE CreateThread(
    LPSECURITY_ATTRIBUTES lpThreadAttributes,
    DWORD dwStackSize,
    LPTHREAD_START_ROUTINE lpStartAddress,
    LPVOID lpParameter,
    DWORD dwCreationFlags,
    LPDWORD lpThreadId
);

其各参数如它们的名称所说，分别是：线程属性（用于在NT下进行线程的安全属性设置，在9X下无效），堆栈大小，
起始地址，参数，创建标志（用于设置线程创建时的状态），线程ID，最后返回线程Handle。其中的起始地址就是线
程函数的入口，直至线程函数结束，线程也就结束了。

因为CreateThread参数很多，而且是Windows的API，所以在C Runtime Library里提供了一个通用的线程函数（理论上
可以在任何支持线程的OS中使用）：
unsigned long _beginthread(void (_USERENTRY *__start)(void *), unsigned __stksize, void *__arg);

Delphi也提供了一个相同功能的类似函数：
function BeginThread(
    SecurityAttributes: Pointer;
    StackSize: LongWord;
    ThreadFunc: TThreadFunc;
    Parameter: Pointer;
    CreationFlags: LongWord;
    var ThreadId: LongWord
): Integer;

这三个函数的功能是基本相同的，它们都是将线程函数中的代码放到一个独立的线程中执行。线程函数与一般函数的
最大不同在于，线程函数一启动，这三个线程启动函数就返回了，主线程继续向下执行，而线程函数在一个独立的线
程中执行，它要执行多久，什么时候返回，主线程是不管也不知道的。
正常情况下，线程函数返回后，线程就终止了。但也有其它方式：

Windows API：
VOID ExitThread( DWORD dwExitCode );

C Runtime Library：
void _endthread(void);

Delphi Runtime Library：
procedure EndThread(ExitCode: Integer);

为了记录一些必要的线程数据（状态/属性等），OS会为线程创建一个内部Object，如在Windows中那个Handle便是这
个内部Object的Handle，所以在线程结束的时候还应该释放这个Object。

虽然说用API或RTL(Runtime Library)已经可以很方便地进行多线程编程了，但是还是需要进行较多的细节处理，为此
Delphi在Classes单元中对线程作了一个较好的封装，这就是VCL的线程类：TThread
使用这个类也很简单，大多数的Delphi书籍都有说，基本用法是：先从TThread派生一个自己的线程类（因为TThread
是一个抽象类，不能生成实例），然后是Override抽象方法：Execute（这就是线程函数，也就是在线程中执行的代码
部分），如果需要用到可视VCL对象，还需要通过Synchronize过程进行。关于之方面的具体细节，这里不再赘述，请
参考相关书籍。

本文接下来要讨论的是TThread类是如何对线程进行封装的，也就是深入研究一下TThread类的实现。因为只是真正地
了解了它，才更好地使用它。
下面是DELPHI7中TThread类的声明（本文只讨论在Windows平台下的实现，所以去掉了所有有关Linux平台部分的代码
）：

TThread = class
private
    FHandle: THandle;
    FThreadID: THandle;
    FCreateSuspended: Boolean;
    FTerminated: Boolean;
    FSuspended: Boolean;
    FFreeOnTerminate: Boolean;
    FFinished: Boolean;
    FReturnValue: Integer;
    FOnTerminate: TNotifyEvent;
    FSynchronize: TSynchronizeRecord;
    FFatalException: TObject;
    procedure CallOnTerminate;
    class procedure Synchronize(ASyncRec: PSynchronizeRecord); overload;
    function GetPriority: TThreadPriority;
    procedure SetPriority(Value: TThreadPriority);
    procedure SetSuspended(Value: Boolean);
protected
    procedure CheckThreadError(ErrCode: Integer); overload;
    procedure CheckThreadError(Success: Boolean); overload;
    procedure DoTerminate; virtual;
    procedure Execute; virtual; abstract;
    procedure Synchronize(Method: TThreadMethod); overload;
    property ReturnValue: Integer read FReturnValue write FReturnValue;
    property Terminated: Boolean read FTerminated;
public
    constructor Create(CreateSuspended: Boolean);
    destructor Destroy; override;
    procedure AfterConstruction; override;
    procedure Resume;
    procedure Suspend;
    procedure Terminate;
    function WaitFor: LongWord;
    class procedure Synchronize(AThread: TThread; AMethod: TThreadMethod); overload;
    class procedure StaticSynchronize(AThread: TThread; AMethod: TThreadMethod);
    property FatalException: TObject read FFatalException;
    property FreeOnTerminate: Boolean read FFreeOnTerminate write FFreeOnTerminate;
    property Handle: THandle read FHandle;
    property Priority: TThreadPriority read GetPriority write SetPriority;
    property Suspended: Boolean read FSuspended write SetSuspended;
    property ThreadID: THandle read FThreadID;
    property OnTerminate: TNotifyEvent read FOnTerminate write FOnTerminate;
end;

TThread类在Delphi的RTL里算是比较简单的类，类成员也不多，类属性都很简单明白，本文将只对几个比较重要的类
成员方法和唯一的事件：OnTerminate作详细分析。
首先就是构造函数：
constructor TThread.Create(CreateSuspended: Boolean);
begin
    inherited Create;
    AddThread;
    FSuspended := CreateSuspended;
    FCreateSuspended := CreateSuspended;
    FHandle := BeginThread(nil, 0, @ThreadProc, Pointer(Self), CREATE_SUSPENDED, FThreadID);
    if FHandle = 0 then
        raise EThread.CreateResFmt(@SThreadCreateError, [SysErrorMessage(GetLastError)]);
end;
虽然这个构造函数没有多少代码，但却可以算是最重要的一个成员，因为线程就是在这里被创建的。
在通过Inherited调用TObject.Create后，第一句就是调用一个过程：AddThread，其源码如下：
procedure AddThread;
begin
    InterlockedIncrement(ThreadCount);
end;

同样有一个对应的RemoveThread：
procedure RemoveThread;
begin
InterlockedDecrement(ThreadCount);
end;
它们的功能很简单，就是通过增减一个全局变量来统计进程中的线程数。只是这里用于增减变量的并不是常用的
Inc/Dec过程，而是用了InterlockedIncrement/InterlockedDecrement这一对过程，它们实现的功能完全一样，都是
对变量加一或减一。但它们有一个最大的区别，那就是InterlockedIncrement/InterlockedDecrement是线程安全的。
即它们在多线程下能保证执行结果正确，而Inc/Dec不能。或者按操作系统理论中的术语来说，这是一对“原语”操作。

以加一为例来说明二者实现细节上的不同：
一般来说，对内存数据加一的操作分解以后有三个步骤：
1、从内存中读出数据
2、数据加一
3、存入内存
现在假设在一个两个线程的应用中用Inc进行加一操作可能出现的一种情况：
1、线程A从内存中读出数据（假设为3）
2、线程B从内存中读出数据（也是3）
3、线程A对数据加一（现在是4）
4、线程B对数据加一（现在也是4）
5、线程A将数据存入内存（现在内存中的数据是4）
6、线程B也将数据存入内存（现在内存中的数据还是4，但两个线程都对它加了一，应该是5才对，所以这里出现了
错误的结果）

而用InterlockIncrement过程则没有这个问题，因为所谓“原语”是一种不可中断的操作，即操作系统能保证在一个
“原语”执行完毕前不会进行线程切换。所以在上面那个例子中，只有当线程A执行完将数据存入内存后，线程B才可
以开始从中取数并进行加一操作，这样就保证了即使是在多线程情况下，结果也一定会是正确的。

前面那个例子也说明一种“线程访问冲突”的情况，这也就是为什么线程之间需要“同步”（Synchronize），关于这
个，在后面说到同步时还会再详细讨论。

说到同步，有一个题外话：加拿大滑铁卢大学的教授李明曾就Synchronize一词在“线程同步”中被译作“同步”提出
过异议，个人认为他说的其实很有道理。在中文中“同步”的意思是“同时发生”，而“线程同步”目的就是避免这
种“同时发生”的事情。而在英文中，Synchronize的意思有两个：一个是传统意义上的同步（To occur at the same
time），另一个是“协调一致”（To operate in unison）。在“线程同步”中的Synchronize一词应该是指后面一种
意思，即“保证多个线程在访问同一数据时，保持协调一致，避免出错”。不过像这样译得不准的词在IT业还有很多
，既然已经是约定俗成了，本文也将继续沿用，只是在这里说明一下，因为软件开发是一项细致的工作，该弄清楚的
，绝不能含糊。

扯远了，回到TThread的构造函数上，接下来最重要就是这句了：
FHandle := BeginThread(nil, 0, @ThreadProc, Pointer(Self), CREATE_SUSPENDED, FThreadID);
这里就用到了前面说到的Delphi RTL函数BeginThread，它有很多参数，关键的是第三、四两个参数。第三个参数就是
前面说到的线程函数，即在线程中执行的代码部分。第四个参数则是传递给线程函数的参数，在这里就是创建的线程
对象（即Self）。其它的参数中，第五个是用于设置线程在创建后即挂起，不立即执行（启动线程的工作是在
AfterConstruction中根据CreateSuspended标志来决定的），第六个是返回线程ID。

现在来看TThread的核心：线程函数ThreadProc。有意思的是这个线程类的核心却不是线程的成员，而是一个全局函数
（因为BeginThread过程的参数约定只能用全局函数）。下面是它的代码：

function ThreadProc(Thread: TThread): Integer;
var
    FreeThread: Boolean;
begin
      try
            if not Thread.Terminated then
            try
                Thread.Execute;
            except
                Thread.FFatalException := AcquireExceptionObject;
            end;
      finally
            FreeThread := Thread.FFreeOnTerminate;
            Result := Thread.FReturnValue;
            Thread.DoTerminate;
            Thread.FFinished := True;
            SignalSyncEvent;
            if FreeThread then Thread.Free;
            EndThread(Result);
      end;
end;
虽然也没有多少代码，但却是整个TThread中最重要的部分，因为这段代码是真正在线程中执行的代码。下面对代码作
逐行说明：
首先判断线程类的Terminated标志，如果未被标志为终止，则调用线程类的Execute方法执行线程代码，因为TThread
是抽象类，Execute方法是抽象方法，所以本质上是执行派生类中的Execute代码。

所以说，Execute就是线程类中的线程函数，所有在Execute中的代码都需要当作线程代码来考虑，如防止访问冲突等。
如果Execute发生异常，则通过AcquireExceptionObject取得异常对象，并存入线程类的FFatalException成员中。
最后是线程结束前做的一些收尾工作。局部变量FreeThread记录了线程类的FreeOnTerminated属性的设置，然后将线
程返回值设置为线程类的返回值属性的值。然后执行线程类的DoTerminate方法。

DoTerminate方法的代码如下：
procedure TThread.DoTerminate;
begin
if Assigned(FOnTerminate) then Synchronize(CallOnTerminate);
end;

很简单，就是通过Synchronize来调用CallOnTerminate方法，而CallOnTerminate方法的代码如下，就是简单地调用
OnTerminate事件：
procedure TThread.CallOnTerminate;
begin
if Assigned(FOnTerminate) then FOnTerminate(Self);
end;

因为OnTerminate事件是在Synchronize中执行的，所以本质上它并不是线程代码，而是主线程代码（具体见后面对
Synchronize的分析）。

执行完OnTerminate后，将线程类的FFinished标志设置为True。接下来执行SignalSyncEvent过程，其代码如下：
procedure SignalSyncEvent;
begin
SetEvent(SyncEvent);
end;

也很简单，就是设置一下一个全局Event：SyncEvent，关于Event的使用，本文将在后文详述，而SyncEvent的用途将
在WaitFor过程中说明。

然后根据FreeThread中保存的FreeOnTerminate设置决定是否释放线程类，在线程类释放时，还有一些些操作，详见接
下来的析构函数实现。
最后调用EndThread结束线程，返回线程返回值。至此，线程完全结束。
说完构造函数，再来看析构函数：
destructor TThread.Destroy;
begin
if (FThreadID <> 0) and not FFinished then begin
      Terminate;
      if FCreateSuspended then
          Resume;
      WaitFor;
end;
if FHandle <> 0 then CloseHandle(FHandle);
inherited Destroy;
FFatalException.Free;
RemoveThread;
end;

在线程对象被释放前，首先要检查线程是否还在执行中，如果线程还在执行中（线程ID不为0，并且线程结束标志未设
置），则调用Terminate过程结束线程。Terminate过程只是简单地设置线程类的Terminated标志，如下面的代码：

procedure TThread.Terminate;
begin
FTerminated := True;
end;

所以线程仍然必须继续执行到正常结束后才行，而不是立即终止线程，这一点要注意。

在这里说一点题外话：很多人都问过我，如何才能“立即”终止线程（当然是指用TThread创建的线程）。结果当然是
不行！终止线程的唯一办法就是让Execute方法执行完毕，所以一般来说，要让你的线程能够尽快终止，必须在
Execute方法中在较短的时间内不断地检查Terminated标志，以便能及时地退出。这是设计线程代码的一个很重要的原
则！

当然如果你一定要能“立即”退出线程，那么TThread类不是一个好的选择，因为如果用API强制终止线程的话，最终
会导致TThread线程对象不能被正确释放，在对象析构时出现Access Violation。这种情况你只能用API或RTL函数来创
建线程。

如果线程处于启动挂起状态，则将线程转入运行状态，然后调用WaitFor进行等待，其功能就是等待到线程结束后才继
续向下执行。关于WaitFor的实现，将放到后面说明。

线程结束后，关闭线程Handle（正常线程创建的情况下Handle都是存在的），释放操作系统创建的线程对象。
然后调用TObject.Destroy释放本对象，并释放已经捕获的异常对象，最后调用RemoveThread减小进程的线程数。

其它关于Suspend/Resume及线程优先级设置等方面，不是本文的重点，不再赘述。下面要讨论的是本文的另两个重点
：Synchronize和WaitFor。

但是在介绍这两个函数之前，需要先介绍另外两个线程同步技术：事件和临界区。

事件（Event）与Delphi中的事件有所不同。从本质上说，Event其实相当于一个全局的布尔变量。它有两个赋值操作
：Set和Reset，相当于把它设置为True或False。而检查它的值是通过WaitFor操作进行。对应在Windows平台上，是三
个API函数：SetEvent、ResetEvent、WaitForSingleObject（实现WaitFor功能的API还有几个，这是最简单的一个）。

这三个都是原语，所以Event可以实现一般布尔变量不能实现的在多线程中的应用。Set和Reset的功能前面已经说过了
，现在来说一下WaitFor的功能：

WaitFor的功能是检查Event的状态是否是Set状态（相当于True），如果是则立即返回，如果不是，则等待它变为Set
状态，在等待期间，调用WaitFor的线程处于挂起状态。另外WaitFor有一个参数用于超时设置，如果此参数为0，则不
等待，立即返回Event的状态，如果是INFINITE则无限等待，直到Set状态发生，若是一个有限的数值，则等待相应的
毫秒数后返回Event的状态。

当Event从Reset状态向Set状态转换时，唤醒其它由于WaitFor这个Event而挂起的线程，这就是它为什么叫Event的原
因。所谓“事件”就是指“状态的转换”。通过Event可以在线程间传递这种“状态转换”信息。

当然用一个受保护（见下面的临界区介绍）的布尔变量也能实现类似的功能，只要用一个循环检查此布尔值的代码来
代替WaitFor即可。从功能上说完全没有问题，但实际使用中就会发现，这样的等待会占用大量的CPU资源，降低系统
性能，影响到别的线程的执行速度，所以是不经济的，有的时候甚至可能会有问题。所以不建议这样用。

临界区（CriticalSection）则是一项共享数据访问保护的技术。它其实也是相当于一个全局的布尔变量。但对它的操
作有所不同，它只有两个操作：Enter和Leave，同样可以把它的两个状态当作True和False，分别表示现在是否处于临
界区中。这两个操作也是原语，所以它可以用于在多线程应用中保护共享数据，防止访问冲突。

用临界区保护共享数据的方法很简单：在每次要访问共享数据之前调用Enter设置进入临界区标志，然后再操作数据，
最后调用Leave离开临界区。它的保护原理是这样的：当一个线程进入临界区后，如果此时另一个线程也要访问这个数
据，则它会在调用Enter时，发现已经有线程进入临界区，然后此线程就会被挂起，等待当前在临界区的线程调用
Leave离开临界区，当另一个线程完成操作，调用Leave离开后，此线程就会被唤醒，并设置临界区标志，开始操作数
据，这样就防止了访问冲突。

以前面那个InterlockedIncrement为例，我们用CriticalSection（Windows API）来实现它：
Var
InterlockedCrit : TRTLCriticalSection;
Procedure InterlockedIncrement( var aValue : Integer );
Begin
    EnterCriticalSection( InterlockedCrit );
    Inc( aValue );
    LeaveCriticalSection( InterlockedCrit );
End;

现在再来看前面那个例子：
1. 线程A进入临界区（假设数据为3）
2. 线程B进入临界区，因为A已经在临界区中，所以B被挂起
3. 线程A对数据加一（现在是4）
4. 线程A离开临界区，唤醒线程B（现在内存中的数据是4）
5. 线程B被唤醒，对数据加一（现在就是5了）
6. 线程B离开临界区，现在的数据就是正确的了。

临界区就是这样保护共享数据的访问。

关于临界区的使用，有一点要注意：即数据访问时的异常情况处理。因为如果在数据操作时发生异常，将导致Leave操
作没有被执行，结果将使本应被唤醒的线程未被唤醒，可能造成程序的没有响应。所以一般来说，如下面这样使用临
界区才是正确的做法：

EnterCriticalSection
Try
// 操作临界区数据
Finally
LeaveCriticalSection
End;

最后要说明的是，Event和CriticalSection都是操作系统资源，使用前都需要创建，使用完后也同样需要释放。如
TThread类用到的一个全局Event：SyncEvent和全局CriticalSection：TheadLock，都是在
InitThreadSynchronization和DoneThreadSynchronization中进行创建和释放的，而它们则是在Classes单元的
Initialization和Finalization中被调用的。

由于在TThread中都是用API来操作Event和CriticalSection的，所以前面都是以API为例，其实Delphi已经提供了对它
们的封装，在SyncObjs单元中，分别是TEvent类和TCriticalSection类。用法也与前面用API的方法相差无几。因为
TEvent的构造函数参数过多，为了简单起见，Delphi还提供了一个用默认参数初始化的Event类：TSimpleEvent。

顺便再介绍一下另一个用于线程同步的类：TMultiReadExclusiveWriteSynchronizer，它是在SysUtils单元中定义的
。据我所知，这是Delphi RTL中定义的最长的一个类名，还好它有一个短的别名：TMREWSync。至于它的用处，我想光
看名字就可以知道了，我也就不多说了。

有了前面对Event和CriticalSection的准备知识，可以正式开始讨论Synchronize和WaitFor了。
我们知道，Synchronize是通过将部分代码放到主线程中执行来实现线程同步的，因为在一个进程中，只有一个主线程
。先来看看Synchronize的实现：

procedure TThread.Synchronize(Method: TThreadMethod);
begin
    FSynchronize.FThread := Self;
    FSynchronize.FSynchronizeException := nil;
    FSynchronize.FMethod := Method;
    Synchronize(@FSynchronize);
end;

其中FSynchronize是一个记录类型：
PSynchronizeRecord = ^TSynchronizeRecord;
TSynchronizeRecord = record
    FThread: TObject;
    FMethod: TThreadMethod;
    FSynchronizeException: TObject;
end;

用于进行线程和主线程之间进行数据交换，包括传入线程类对象，同步方法及发生的异常。
在Synchronize中调用了它的一个重载版本，而且这个重载版本比较特别，它是一个“类方法”。所谓类方法，是一种
特殊的类成员方法，它的调用并不需要创建类实例，而是像构造函数那样，通过类名调用。之所以会用类方法来实现
它，是因为为了可以在线程对象没有创建时也能调用它。不过实际中是用它的另一个重载版本（也是类方法）和另一
个类方法StaticSynchronize。下面是这个Synchronize的代码：

class procedure TThread.Synchronize(ASyncRec: PSynchronizeRecord);
var
    SyncProc: TSyncProc;
begin
    if GetCurrentThreadID = MainThreadID then
        ASyncRec.FMethod
    else begin
    SyncProc.Signal := CreateEvent(nil, True, False, nil);
    try
    EnterCriticalSection(ThreadLock);
    try
    if SyncList = nil then
        SyncList := TList.Create;
        SyncProc.SyncRec := ASyncRec;
        SyncList.Add(@SyncProc);
        SignalSyncEvent;
        if Assigned(WakeMainThread) then
            WakeMainThread(SyncProc.SyncRec.FThread);
        LeaveCriticalSection(ThreadLock);
        try
            WaitForSingleObject(SyncProc.Signal, INFINITE);
        finally
            EnterCriticalSection(ThreadLock);
        end;
        finally
            LeaveCriticalSection(ThreadLock);
        end;
        finally
            CloseHandle(SyncProc.Signal);
        end;
        if Assigned(ASyncRec.FSynchronizeException) then
            raise ASyncRec.FSynchronizeException;
    end;
end;

这段代码略多一些，不过也不算太复杂。
首先是判断当前线程是否是主线程，如果是，则简单地执行同步方法后返回。
如果不是主线程，则准备开始同步过程。
通过局部变量SyncProc记录线程交换数据（参数）和一个Event Handle，其记录结构如下：
TSyncProc = record
SyncRec: PSynchronizeRecord;
Signal: THandle;
end;

然后创建一个Event，接着进入临界区（通过全局变量ThreadLock进行，因为同时只能有一个线程进入Synchronize状
态，所以可以用全局变量记录），然后就是把这个记录数据存入SyncList这个列表中（如果这个列表不存在的话，则
创建它）。可见ThreadLock这个临界区就是为了保护对SyncList的访问，这一点在后面介绍CheckSynchronize时会再
次看到。

再接下就是调用SignalSyncEvent，其代码在前面介绍TThread的构造函数时已经介绍过了，它的功能就是简单地将
SyncEvent作一个Set的操作。关于这个SyncEvent的用途，将在后面介绍WaitFor时再详述。

接下来就是最主要的部分了：调用WakeMainThread事件进行同步操作。WakeMainThread是一个TNotifyEvent类型的全
局事件。这里之所以要用事件进行处理，是因为Synchronize方法本质上是通过消息，将需要同步的过程放到主线程中
执行，如果在一些没有消息循环的应用中（如Console或DLL）是无法使用的，所以要使用这个事件进行处理。
而响应这个事件的是Application对象，下面两个方法分别用于设置和清空WakeMainThread事件的响应（来自Forms单元）：

procedure TApplication.HookSynchronizeWakeup;
begin
Classes.WakeMainThread := WakeMainThread;
end;

procedure TApplication.UnhookSynchronizeWakeup;
begin
Classes.WakeMainThread := nil;
end;

上面两个方法分别是在TApplication类的构造函数和析构函数中被调用。
这就是在Application对象中WakeMainThread事件响应的代码，消息就是在这里被发出的，它利用了一个空消息来实现：

procedure TApplication.WakeMainThread(Sender: TObject);
begin
PostMessage(Handle, WM_NULL, 0, 0);
end;

而这个消息的响应也是在Application对象中，见下面的代码（删除无关的部分）：
procedure TApplication.WndProc(var Message: TMessage);
…
begin
    try
        …
        with Message do
        case Msg of
        …
        WM_NULL:
        CheckSynchronize;
        …
    except
        HandleException(Self);
    end;
end;

其中的CheckSynchronize也是定义在Classes单元中的，由于它比较复杂，暂时不详细说明，只要知道它是具体处理
Synchronize功能的部分就好，现在继续分析Synchronize的代码。
在执行完WakeMainThread事件后，就退出临界区，然后调用WaitForSingleObject开始等待在进入临界区前创建的那个
Event。这个Event的功能是等待这个同步方法的执行结束，关于这点，在后面分析CheckSynchronize时会再说明。
注意在WaitForSingleObject之后又重新进入临界区，但没有做任何事就退出了，似乎没有意义，但这是必须的！
因为临界区的Enter和Leave必须严格的一一对应。那么是否可以改成这样呢：

if Assigned(WakeMainThread) then
    WakeMainThread(SyncProc.SyncRec.FThread);
    WaitForSingleObject(SyncProc.Signal, INFINITE);
    finally
        LeaveCriticalSection(ThreadLock);
end;

上面的代码和原来的代码最大的区别在于把WaitForSingleObject也纳入临界区的限制中了。看上去没什么影响，还使
代码大大简化了，但真的可以吗？
事实上是不行！

因为我们知道，在Enter临界区后，如果别的线程要再进入，则会被挂起。而WaitFor方法则会挂起当前线程，直到等
待别的线程SetEvent后才会被唤醒。如果改成上面那样的代码的话，如果那个SetEvent的线程也需要进入临界区的话
，死锁（Deadlock）就发生了（关于死锁的理论，请自行参考操作系统原理方面的资料）。
死锁是线程同步中最需要注意的方面之一！
最后释放开始时创建的Event，如果被同步的方法返回异常的话，还会在这里再次抛出异常。

回到前面CheckSynchronize，见下面的代码：

function CheckSynchronize(Timeout: Integer = 0): Boolean;
var
     SyncProc: PSyncProc;
     LocalSyncList: TList;
begin
     if GetCurrentThreadID <> MainThreadID then
          raise EThread.CreateResFmt(@SCheckSynchronizeError, [GetCurrentThreadID]);
     if Timeout > 0 then
          WaitForSyncEvent(Timeout)
     else
          ResetSyncEvent;
     LocalSyncList := nil;
     EnterCriticalSection(ThreadLock);
     try
          Integer(LocalSyncList) := InterlockedExchange(Integer(SyncList), Integer(LocalSyncList));
          try
               Result := (LocalSyncList <> nil) and (LocalSyncList.Count > 0);
               if Result then begin
                    while LocalSyncList.Count > 0 do begin
                         SyncProc := LocalSyncList[0];
                         LocalSyncList.Delete(0);
                         LeaveCriticalSection(ThreadLock);
                         try
                              try
                                   SyncProc.SyncRec.FMethod;
                              except
                                   SyncProc.SyncRec.FSynchronizeException := AcquireExceptionObject;
                              end;
                         finally
                              EnterCriticalSection(ThreadLock);
                         end;
                         SetEvent(SyncProc.signal);
                    end;
               end;
          finally
               LocalSyncList.Free;
          end;
     finally
          LeaveCriticalSection(ThreadLock);
     end;
end;

首先，这个方法必须在主线程中被调用（如前面通过消息传递到主线程），否则就抛出异常。
接下来调用ResetSyncEvent（它与前面SetSyncEvent对应的，之所以不考虑WaitForSyncEvent的情况，是因为只有在
Linux版下才会调用带参数的CheckSynchronize，Windows版下都是调用默认参数0的CheckSynchronize）。
现在可以看出SyncList的用途了：它是用于记录所有未被执行的同步方法的。因为主线程只有一个，而子线程可能有
很多个，当多个子线程同时调用同步方法时，主线程可能一时无法处理，所以需要一个列表来记录它们。
在这里用一个局部变量LocalSyncList来交换SyncList，这里用的也是一个原语：InterlockedExchange。同样，这里
也是用临界区将对SyncList的访问保护起来。
只要LocalSyncList不为空，则通过一个循环来依次处理累积的所有同步方法调用。最后把处理完的LocalSyncList释
放掉，退出临界区。

再来看对同步方法的处理：首先是从列表中移出（取出并从列表中删除）第一个同步方法调用数据。然后退出临界区
（原因当然也是为了防止死锁）。
接着就是真正的调用同步方法了。
如果同步方法中出现异常，将被捕获后存入同步方法数据记录中。
重新进入临界区后，调用SetEvent通知调用线程，同步方法执行完成了（详见前面Synchronize中的
WaitForSingleObject调用）。
至此，整个Synchronize的实现介绍完成。

最后来说一下WaitFor，它的功能就是等待线程执行结束。其代码如下：
function TThread.WaitFor: LongWord;
var
    H: array[0..1] of THandle;
    WaitResult: Cardinal;
    Msg: TMsg;
begin
    H[0] := FHandle;
    if GetCurrentThreadID = MainThreadID then begin
        WaitResult := 0;
        H[1] := SyncEvent;
        repeat
            { This prevents a potential deadlock if the background thread does a SendMessage to the foreground thread }
            if WaitResult = WAIT_OBJECT_0 + 2 then
                PeekMessage(Msg, 0, 0, 0, PM_NOREMOVE);
            WaitResult := MsgWaitForMultipleObjects(2, H, False, 1000, QS_SENDMESSAGE);
            CheckThreadError(WaitResult <> WAIT_FAILED);
            if WaitResult = WAIT_OBJECT_0 + 1 then
                CheckSynchronize;
        until WaitResult = WAIT_OBJECT_0;
    end else
        WaitForSingleObject(H[0], INFINITE);
    CheckThreadError(GetExitCodeThread(H[0], Result));
end;

如果不是在主线程中执行WaitFor的话，很简单，只要调用WaitForSingleObject等待此线程的Handle为Signaled状态
即可。

如果是在主线程中执行WaitFor则比较麻烦。首先要在Handle数组中增加一个SyncEvent，然后循环等待，直到线程结
束（即MsgWaitForMultipleObjects返回WAIT_OBJECT_0，详见MSDN中关于此API的说明）。
在循环等待中作如下处理：如果有消息发生，则通过PeekMessage取出此消息（但并不把它从消息循环中移除），然后
调用MsgWaitForMultipleObjects来等待线程Handle或SyncEvent出现Signaled状态，同时监听消息（QS_SENDMESSAGE
参数，详见MSDN中关于此API的说明）。可以把此API当作一个可以同时等待多个Handle的WaitForSingleObject。如果
是SyncEvent被SetEvent（返回WAIT_OBJECT_0 + 1），则调用CheckSynchronize处理同步方法。
为什么在主线程中调用WaitFor必须用MsgWaitForMultipleObjects，而不能用WaitForSingleObject等待线程结束呢？
因为防止死锁。由于在线程函数Execute中可能调用Synchronize处理同步方法，而同步方法是在主线程中执行的，如
果用WaitForSingleObject等待的话，则主线程在这里被挂起，同步方法无法执行，导致线程也被挂起，于是发生死锁。
而改用WaitForMultipleObjects则没有这个问题。首先，它的第三个参数为False，表示只要线程Handle或SyncEvent
中只要有一个Signaled即可使主线程被唤醒，至于加上QS_SENDMESSAGE是因为Synchronize是通过消息传到主线程来的
，所以还要防止消息被阻塞。这样，当线程中调用Synchronize时，主线程就会被唤醒并处理同步调用，在调用完成后
继续进入挂起等待状态，直到线程结束。
至此，对线程类TThread的分析可以告一个段落了，对前面的分析作一个总结：
1、线程类的线程必须按正常的方式结束，即Execute执行结束，所以在其中的代码中必须在适当的地方加入足够多
的对Terminated标志的判断，并及时退出。如果必须要“立即”退出，则不能使用线程类，而要改用API或RTL函数。
2、对可视VCL的访问要放在Synchronize中，通过消息传递到主线程中，由主线程处理。
3、线程共享数据的访问应该用临界区进行保护（当然用Synchronize也行）。
4、线程通信可以采用Event进行（当然也可以用Suspend/Resume）。
5、当在多线程应用中使用多种线程同步方式时，一定要小心防止出现死锁。
6、等待线程结束要用WaitFor方法。

Khan's Notebook 2006-11-21 11:46 发表评论

关于Utf8编码的几个函数

Khan's Notebook — Thu, 19 Jan 2006 07:06:00 GMT

最近一段时间老弄Utf8编码,工作时写了几个函数,给大家指正一下

//////////////////////////////////////////////
//---------取得utf8字符的长度---------------//
//Str:String 源字符串
//Result:Integer utf8字符串长度
class function TPduPush.getUTF8Len(Str: string): Integer;
var
     i: integer;
     tmpChar: Pchar;
begin
     tmpChar := pchar(str);
     i := 0;
     result := 0;
     while i < length(tmpChar) do begin
          if ord(tmpChar[i]) < $80 then begin
               i := i + 1;
               result := result + 1;
          end else begin
               i := i + 2;
               result := result + 3;
          end;
     end;
end;

////////////////////////////////////////////////
//----------取得字符串中的字符个数------------//
//str:String 源字符串
//Result:Integer 字符个数,兼容中文双字节
class function TPduPush.getAnsiLen(Str: string): integer;
var
     i: integer;
     tmpChar: Pchar;
begin
     tmpChar := pchar(str);
     i := 0;
     result := 0;
     while i < length(tmpChar) do begin
          if ord(tmpChar[i]) < $80 then
               i := i + 1
          else
               i := i + 2;
          result := result + 1;
     end;
end;


/////////////////////////////////////////////////
//---------截取指定长度的utf8字符串------------//
//str:string 源字符串
//count:Integer 指定长度  一个汉字占三个字节,长度只能小,不能大
//Result:string 截取后的utf8字符串
class function TPduPush.getUTF8String(Str: string; count: Integer): string;
var
     i, j: integer;
     tmpChar: Pchar;
begin
     tmpChar := pchar(str);
     i := 0;
     j := 0;
     result := '';

     while i < length(tmpChar) do begin
          if j >= count then break;  //英文转码后不能超过指定的位数
          if ord(tmpChar[i]) < $80 then begin
               result := result + string(tmpChar[i]);
               i := i + 1;
               j := j + 1;
          end else begin
               if j + 2 >= count then break;  //汉字转码后不能超过指定的位数
               result := result + string(tmpChar[i]) + string(tmpChar[i + 1]);
               i := i + 2;
               j := j + 3;
          end;
     end;
end;

Khan's Notebook 2006-01-19 15:06 发表评论

[导入]今天在这个blog上找到了ota bookmark的文档,打算在我的程序里面加上发送ota bookmark的功能

Khan's Notebook — Thu, 12 Jan 2006 01:56:00 GMT

首先需要写一个bookmark的xml文件，这个格式可以去nokia网站下载。下面是一个例子：



          http://www.bookmark.com"/>

尽量让name和url短点，这样编码后可以放到一条短消息里面，而不需要把一个设置拆分成多个短消息体。大致的一个封装是把xml文件转成wbxml，然后再在外面封装WSP层，最外面是WDP层。

WDP的一般格式是“0B0504C34FC002000304xxyy”，其中xx就是整个数据包的总片断数目，而yy表示当前片断是第几个片断。举个例子，一个简单的bookmark全部放在一个sms中这样xx＝01，yy＝01。
下面是每个byte的意思:

bookmark的WSP层的格式一般是"01062D1F2A6170706C69636174696F6E2F782D7761702D70726F762E62726F777365722D626F6F6B6D61726B730081EA"
每个byte的具体意思是：

# 01 | Transaction ID /
# 06 | PDU type (push)
# xx | Header length (content type headers)
# 1F | Value length quote length greater than 30
# 2A | Value length (value name not used)
# xx | Mimetype encoded, variable bytes          | application/x-wap-prov.browser-{bookmarks | settings}
# 00 | Null termination of content type string   |
# 81 | Charset                                   | Well known PARM. (short integer)
# EA | UTF-8 (using short integer)
最里层就是WBXML了，首先必须有个xml的头"01016A00"

至于其他的具体编码可以去http://www.forum.nokia.com查看OTA_settings_general_7_0.pdf这个文档，里面很详细的描述了每一个XML元素对应的十六进制。最后注意一点，发送的时候要按8bit格式的发送，而不是7bit格式。

http://www.cnblogs.com/zhengyun_ustc/archive/2005/09/05/otawapbookmark.html

[SMS&WAP]实例讲解制作OTA短信来自动配置手机WAP书签[附源码]
摘要:OTA，即Over The Air，国内翻译为空中下载。
OTA标准由爱立信和诺基亚共同制订。OTA涵盖了许多范围，比如Kjava中的应用程序下载也是通过OTA。我们这篇文章主要讲的是，通过短信方式空中下载配置信息，参考的文档是OTA_settings_general_7_0.pdf。
规范中定义了三种Setting：
? 浏览器设置
? 浏览器的书签设置
? SyncML设置
也就是说，你通过发送短信可以帮助用户手机配置这三种设置。

原则上，你只要看了OTA_settings_general_7_0.pdf，并参照OTA_service_settings_example_v11.pdf，就可以轻松地制作出符合规范的OTA短信。
但是，本文档的目的就是让你简单粗暴地直奔主题，看完这篇文档后，就了解了OTA短信的概念，通过以下代码：
OTAMessage
OTAMessage message = new OTAMessage();
txtOTAResult.Text = message.Get

Khan's Notebook 2006-01-12 09:56 发表评论

[导入]在偶机器上找到一个读cpu串号的代码,delphi的,记录一下(申明是人家的代码)

Khan's Notebook — Thu, 12 Jan 2006 01:56:00 GMT

unit CPU;

interface

uses
SysUtils;

type
TCPUID = array[1..4] of Longint;
TVendor = array[0..11] of char;

function GetCPUID: TCPUID; assembler; register;
function GetCPUVendor: TVendor; assembler; register;
function GetCPUInfo: string;

implementation

function GetCPUID: TCPUID; assembler; register;
asm
PUSH    EBX         {Save affected register}
PUSH    EDI
MOV     EDI,EAX      {@Resukt}
MOV     EAX,1
DW      $A20F        {CPUID Command}
STOSD                {CPUID[1]}
MOV     EAX,EBX
STOSD                {CPUID[2]}
MOV     EAX,ECX
STOSD                {CPUID[3]}
MOV     EAX,EDX
STOSD                {CPUID[4]}
POP     EDI          {Restore registers}
POP     EBX
end;

function GetCPUVendor: TVendor; assembler; register;
asm
PUSH    EBX          {Save affected register}
PUSH    EDI
MOV     EDI,EAX      {@Result (TVendor)}
MOV     EAX,0
DW      $A20F        {CPUID Command}
MOV     EAX,EBX
XCHG    EBX,ECX      {save ECX result}
MOV     ECX,4
@1:
STOSB
SHR     EAX,8
LOOP    @1
MOV     EAX,EDX
MOV     ECX,4
@2:
STOSB
SHR     EAX,8
LOOP    @2
MOV     EAX,EBX
MOV     ECX,4
@3:
STOSB
SHR     EAX,8
LOOP    @3
POP     EDI          {Restore registers}
POP     EBX
end;

function GetCPUInfo: string;
var
CPUID: TCPUID;
I: Integer;
S: TVendor;
begin
for I := Low(CPUID) to High(CPUID) do
    CPUID[I] := -1;

CPUID := GetCPUID;

S := GetCPUVendor;

Result := S + IntToHex(CPUID[1], 8) + IntToHex(CPUID[2], 8)
    + IntToHex(CPUID[3], 8)
    + IntToHex(CPUID[4], 8);
end;

end.

以前中专d时候看ibm 8086/8088汇编有自己写过这些代码d,但是现在过了这么多年,退化到看不懂这些了

Khan's Notebook 2006-01-12 09:56 发表评论

[导入]终于搞定了异步通信了,调试了两天,发现偶还素犯了一个弱智错误

Khan's Notebook — Thu, 12 Jan 2006 01:56:00 GMT

我把client的socket初始化内容写在了message响应函数里面了,每次触发消息的时候就把客户端的socket置0了

服务器端代码如下:

由于比较简单,所以不贴注释了,如果有什么不懂d地方,大家对着翻吧

unit Listener;

interface

uses
SysUtils, Controls, Forms, winsock, Classes, ComCtrls, StdCtrls;

const ASYNC_EVENT = $0400 + 1;
SO_CONDITIONAL_ACCEPT = $3002;
type

TCMSocketMessage = record //select 消息结构
    Msg: Cardinal; //系统消息
    Socket: TSocket; //产生消息的源socket 句柄
    SelectEvent: Word; //select消息
    SelectError: Word; //错误
    Result: Longint;
end;

type
TMain = class(TForm)
    SBar: TStatusBar;
    Memo1: TMemo;
    procedure FormDestroy(Sender: TObject);
    procedure FormCreate(Sender: TObject);
private
    s: TSocket;
    SClinent: TSocket;
    procedure bindAddr;
    procedure CMIncCount(var Msg: TCMSocketMessage); message ASYNC_EVENT;
    procedure listenAddr;
    { Private declarations }
public
    { Public declarations }
end;

var
Main: TMain;

implementation

{$R *.dfm}

procedure TMain.FormDestroy(Sender: TObject);
begin
closeSocket(s);
WSACleanup();
end;

procedure TMain.FormCreate(Sender: TObject);
var
wsa: TWSaData;
flag: integer;
begin
SClinent := 0;
//SysUtils.BoolToStr()
flag := WSAStartup($0202, wsa); //加载winsock
if flag <> 0 then begin
SBar.Panels[2].Text := format('错误号:%d', [WSAGetLastError()]);
SBar.Panels[1].Text := 'Winsock库加载失败';
end;

bindAddr;
listenAddr;
end;

procedure TMain.bindAddr;
var
addr: TSockAddrIn;
flag: integer;
begin
s := socket(AF_INET, SOCK_STREAM, IPPROTO_TCP); //服务器端的socket
addr.sin_port := htons(45531);
addr.sin_family := AF_INET;
addr.sin_addr.S_addr := INADDR_ANY; //inet_addr(pchar(host));

flag := bind(s, addr, sizeof(addr));
if flag = SOCKET_ERROR then begin
    SBar.Panels[2].Text := format('错误号:%d', [WSAGetLastError()]);
    SBar.Panels[1].Text := 'IP绑定错误';
end else begin
    flag := WSAAsyncSelect(s, Handle, ASYNC_EVENT, FD_ACCEPT or FD_CONNECT or FD_CLOSE or FD_READ or FD_WRITE);
    if flag = SOCKET_ERROR then begin
      SBar.Panels[2].Text := format('错误号:%d', [WSAGetLastError()]);
      SBar.Panels[1].Text := 'WSAAsyncSelect错误';
    end;
end;
end;

procedure TMain.listenAddr;
var flag: integer;
begin
flag := listen(s, 10);
if flag = SOCKET_ERROR then begin
SBar.Panels[2].Text := format('错误号:%d', [WSAGetLastError()]);
SBar.Panels[1].Text := '监听失败';
end;
end;

procedure TMain.CMIncCount(var Msg: TCMSocketMessage);
var
addr: TSockAddrIn;
len: integer;
SendBuf: array[1..1024] of AnsiChar;
recvBuf: array[1..1024] of AnsiChar;
str: string;
OldOpenType {, NewOpenType}: integer;
begin
len := 0;

str := '';

case Msg.SelectEvent of
    FD_READ: begin
        len := sizeof(recvBuf);
        ioctlsocket(SClinent, FIONREAD, Longint(len));
        fillchar(recvBuf, sizeof(recvBuf), 0);
        recv(SClinent, recvBuf, sizeof(recvBuf), 0);

        Memo1.Lines.Add(string(recvBuf));
        Memo1.Lines.Add('read');
        if Memo1.Lines.Count > 10 then
          memo1.Clear;

        sleep(10);
        fillchar(SendBuf, sizeof(SendBuf), 0);
        Strcopy(@SendBuf, pansichar('OK'));
        Send(SClinent, sendbuf, sizeof(sendbuf), 0);
      end;

FD_WRITE: begin

        Memo1.Lines.Add('write');
      end;
    FD_ACCEPT: begin
        len := sizeof(OldOpenType);

        if getsockopt(INVALID_SOCKET, SOL_SOCKET, SO_OPENTYPE, PChar(@OldOpenType), len) = 0 then begin
          try
            len := sizeof(addr);
            SClinent := accept(s, @addr, @len);

            if SClinent = INVALID_SOCKET then begin
              Memo1.Lines.Add('无效的socket:' + inttostr(SClinent));
            end;
            Memo1.Lines.Add('accept');
          finally
            len := sizeof(OldOpenType);
            setsockopt(INVALID_SOCKET, SOL_SOCKET, SO_OPENTYPE, PChar(@OldOpenType), len);
          end;
        end;
        WSAAsyncSelect(SClinent, handle, ASYNC_EVENT, $33);

      end;
    FD_CONNECT: begin
        Memo1.Lines.Add('connect');
      end;
    FD_CLOSE: begin
        Memo1.Lines.Add('close');
      end;
end;
end;

end.
//由于服务器端没有缓存机制,所以多个client连接的时候,第二个client的socket会覆盖前一个的,大家看情况改改就行了,网络上大把代码都是用控件或者其他封装好d类来写d,所以资料郁闷死了.

客户端代码:

program Client;

{$APPTYPE CONSOLE}

uses
SysUtils,
windows,
winsock;

var
addr: TSockAddrIn;
wsa: TWSaData;
flag: integer;
s: TSocket;
Host: string;
Port: Word;
BufSend: array[1..1024] of Ansichar; //中间信息
BufRev: array[1..1024] of Ansichar;
i: Integer;
begin
{ TODO -oUser -cConsole Main : Insert code here }

Host := '127.0.0.1';
port := 45531;

flag := WSAStartup($0202, wsa); //加载winsock
if flag <> 0 then begin
    Writeln(format('错误号:%d', [WSAGetLastError()]));
    Writeln('Winsock库加载失败');
end else begin
    Writeln('Winsock库加载成功')
end;

//s := socket(AF_INET, SOCK_STREAM, IPPROTO_TCP); //服务器端的socket
s := socket(PF_INET, SOCK_STREAM, 0);
FillChar(addr, sizeof(addr), 0); //初始化地址空间

addr.sin_port := htons(port);
addr.sin_family := AF_INET;
addr.sin_addr.S_addr := {INADDR_ANY; } inet_addr(pchar(host));

if connect(s, addr, sizeof(addr)) = 0 then begin
Writeln('主机:' + Host + ' 连接成功')
end else begin
Writeln('主机:' + Host + ' 连接失败');
end;

FillChar(BufSend, 1024, 0);

StrPCopy(@BufSend, '测试信息包');
for i := 0 to 100 do begin
    Writeln(inttostr(s));
    if Send(s, Bufsend, Length(BufSend), 0) <> SOCKET_ERROR then begin
      Writeln('消息已发送');
      sleep(500);

      FillChar(BufRev, 1024, 0);
      //strcopy(bufsend,pansichar('a'))
      if recv(s, BufRev, Length(BufSend), 0) <> SOCKET_ERROR then begin
        writeln('接收到的信息:' + trim(string(BufRev)));
      end else begin
        Writeln('接收消息失败!')
      end;

    end else begin
      Writeln('消息发送失败')
    end;
end;

if closeSocket(s) = 0 then begin
Writeln('已经关闭socket')
end else begin
Writeln('关闭socket 出错')
end;

WSACleanup();
Readln;
end.

Khan's Notebook 2006-01-12 09:56 发表评论

关于delphi 的函数调用和参数传递方式深入研究之疑惑

Khan's Notebook — Mon, 22 Nov 2004 14:14:00 GMT

希望大家帮忙解答. delphi的函数的参数传递方式从我反汇编的代码来看好像不光是简单的压栈,涉及到了多个寄存器

关于delphi 的函数调用和参数传递方式深入研究

delphi 代码如下:

program Project1;

uses windows, SysUtils;

function a(d, dd: word; s, j, f: string): word;
begin
d := d - 1;
result := d + dd;
messagebox(0, pchar(inttostr(d) + s), pchar(inttostr(dd)), $0);
end;

var s: string;

begin
s := 'sssssssssss';
{ asm
    mov dx,$11
    mov ax,$33
    call a;
end; }
a($33, $11, 'sssss', s, s);
end.

汇编代码:
00407CA8   . 447C4000       DD Project1.00407C44
00407CAC > $ 55             PUSH EBP     //保存栈顶
00407CAD   . 8BEC           MOV EBP,ESP //初始化堆栈
00407CAF   . 83C4 F0        ADD ESP,-10 //开辟10个字节的栈
00407CB2   . B8 6C7C4000    MOV EAX,Project1.00407C6C
00407CB7   . E8 34C7FFFF    CALL Project1.004043F0
00407CBC   . 33C0           XOR EAX,EAX //EAX清0
00407CBE   . 55             PUSH EBP     //保存栈顶
00407CBF   . 68 037D4000    PUSH Project1.00407D03 //保存返回地址
00407CC4   . 64:FF30        PUSH DWORD PTR FS:[EAX] //
00407CC7   . 64:8920        MOV DWORD PTR FS:[EAX],ESP //
00407CCA   . B8 48984000    MOV EAX,Project1.00409848
00407CCF   . BA 187D4000    MOV EDX,Project1.00407D18                ; ASCII "sssssssssss" //初始化局部变量
00407CD4   . E8 2FB9FFFF    CALL Project1.00403608
00407CD9   . 68 2C7D4000    PUSH Project1.00407D2C                   ; ASCII "jjjjjjjjjj"
00407CDE   . 68 407D4000    PUSH Project1.00407D40                   ; ASCII "ffffffffffff"
00407CE3   . B9 587D4000    MOV ECX,Project1.00407D58                ; ASCII "sssss"
00407CE8   . 66:BA 1100     MOV DX,11
00407CEC   . 66:B8 3300     MOV AX,33
00407CF0   . E8 9BFEFFFF    CALL Project1.00407B90                   //调用函数
00407CF5   . 33C0           XOR EAX,EAX
00407CF7   . 5A             POP EDX
00407CF8   . 59             POP ECX
00407CF9   . 59             POP ECX
00407CFA   . 64:8910        MOV DWORD PTR FS:[EAX],EDX
00407CFD   . 68 0A7D4000    PUSH Project1.00407D0A
00407D02   > C3             RETN                                     ; RET used as a jump to 00407D0A

00407D03   .^E9 D4B2FFFF    JMP Project1.00402FDC
00407D08   .^EB F8          JMP SHORT Project1.00407D02
00407D0A     E8             DB E8
00407D0B     B5             DB B5
00407D0C     B7             DB B7
00407D0D     FF             DB FF
00407D0E     FF             DB FF
00407D0F     00             DB 00
00407D10   . FFFFFFFF       DD FFFFFFFF
00407D14   . 0B000000       DD 0000000B
00407D18   . 73 73 73 73 73>ASCII "sssssssssss",0
00407D24   . FFFFFFFF       DD FFFFFFFF
00407D28   . 0A000000       DD 0000000A
00407D2C   . 6A 6A 6A 6A 6A>ASCII "jjjjjjjjjj",0
00407D37     00             DB 00
00407D38   . FFFFFFFF       DD FFFFFFFF
00407D3C   . 0C000000       DD 0000000C
00407D40   . 66 66 66 66 66>ASCII "ffffffffffff",0
00407D4D     00             DB 00
00407D4E     00             DB 00
00407D4F     00             DB 00
00407D50   . FFFFFFFF       DD FFFFFFFF
00407D54   . 05000000       DD 00000005
00407D58   . 73 73 73 73 73>ASCII "sssss",0

function a(d, dd: word; s, j, f: string): word;
函数的代码:

00407B90 /$ 55             PUSH EBP
00407B91 |. 8BEC           MOV EBP,ESP
00407B93 |. 6A 00          PUSH 0
00407B95 |. 6A 00          PUSH 0
00407B97 |. 6A 00          PUSH 0
00407B99 |. 53             PUSH EBX
00407B9A |. 56             PUSH ESI
00407B9B |. 57             PUSH EDI
00407B9C |. 894D FC        MOV DWORD PTR SS:[EBP-4],ECX
00407B9F |. 8BF2           MOV ESI,EDX
00407BA1 |. 8BD8           MOV EBX,EAX
00407BA3 |. 8B45 FC        MOV EAX,DWORD PTR SS:[EBP-4]
00407BA6 |. E8 49BDFFFF    CALL Project1.004038F4
00407BAB |. 8B45 0C        MOV EAX,DWORD PTR SS:[EBP+C]
00407BAE |. E8 41BDFFFF    CALL Project1.004038F4
00407BB3 |. 8B45 08        MOV EAX,DWORD PTR SS:[EBP+8]
00407BB6 |. E8 39BDFFFF    CALL Project1.004038F4
00407BBB |. 33C0           XOR EAX,EAX
00407BBD |. 55             PUSH EBP
00407BBE |. 68 317C4000    PUSH Project1.00407C31
00407BC3 |. 64:FF30        PUSH DWORD PTR FS:[EAX]
00407BC6 |. 64:8920        MOV DWORD PTR FS:[EAX],ESP
00407BC9 |. 4B             DEC EBX
00407BCA |. 8D3C1E         LEA EDI,DWORD PTR DS:[ESI+EBX]
00407BCD |. 6A 00          PUSH 0
00407BCF |. 8D55 F8        LEA EDX,DWORD PTR SS:[EBP-8]
00407BD2 |. 0FB7C6         MOVZX EAX,SI
00407BD5 |. E8 5AD6FFFF    CALL Project1.00405234
00407BDA |. 8B45 F8        MOV EAX,DWORD PTR SS:[EBP-8]
00407BDD |. E8 22BDFFFF    CALL Project1.00403904
00407BE2 |. 50             PUSH EAX
00407BE3 |. 8D55 F4        LEA EDX,DWORD PTR SS:[EBP-C]
00407BE6 |. 0FB7C3         MOVZX EAX,BX
00407BE9 |. E8 46D6FFFF    CALL Project1.00405234
00407BEE |. 8D45 F4        LEA EAX,DWORD PTR SS:[EBP-C]
00407BF1 |. 8B55 FC        MOV EDX,DWORD PTR SS:[EBP-4]
00407BF4 |. E8 33BCFFFF    CALL Project1.0040382C
00407BF9 |. 8B45 F4        MOV EAX,DWORD PTR SS:[EBP-C]
00407BFC |. E8 03BDFFFF    CALL Project1.00403904
00407C01 |. 50             PUSH EAX                                 ; |Text
00407C02 |. 6A 00          PUSH 0                                   ; |hOwner = NULL
00407C04 |. E8 23C9FFFF    CALL            ; \MessageBoxA //这里stdcall方式调用messagebox
00407C09 |. 33C0           XOR EAX,EAX
00407C0B |. 5A             POP EDX
00407C0C |. 59             POP ECX
00407C0D |. 59             POP ECX
00407C0E |. 64:8910        MOV DWORD PTR FS:[EAX],EDX
00407C11 |. 68 387C4000    PUSH Project1.00407C38
00407C16 |> 8D45 F4        LEA EAX,DWORD PTR SS:[EBP-C]
00407C19 |. BA 03000000    MOV EDX,3
00407C1E |. E8 B5B9FFFF    CALL Project1.004035D8
00407C23 |. 8D45 08        LEA EAX,DWORD PTR SS:[EBP+8]
00407C26 |. BA 02000000    MOV EDX,2
00407C2B |. E8 A8B9FFFF    CALL Project1.004035D8
00407C30 \. C3             RETN

debug registers :
eax 00000000
ecx 00010101
edx ffffffff
ebx 7ffdf000
esp 0012ffc0
ebp 0012fff0
esi 00000000
edi 0012d870
eip 00407cad project1.

00407CCA . B8 48984000 MOV EAX,Project1.00409848
00407CCF . BA 187D4000 MOV EDX,Project1.00407D18 ; ASCII "sssssssssss" //初始化局部变量
00407CD4 . E8 2FB9FFFF CALL Project1.00403608
00407CD9 . 68 2C7D4000 PUSH Project1.00407D2C ; ASCII "jjjjjjjjjj"
00407CDE . 68 407D4000 PUSH Project1.00407D40 ; ASCII "ffffffffffff"
00407CE3 . B9 587D4000 MOV ECX,Project1.00407D58 ; ASCII "sssss"
00407CE8 . 66:BA 1100 MOV DX,11
00407CEC . 66:B8 3300 MOV AX,33
00407CF0 . E8 9BFEFFFF CALL Project1.00407B90 //调用函数

函数原型为function a(d, dd: word; s, j, f: string): word;
他的执行顺序是先把J ,f 压栈 , 把 s 存入 ecx ,然后,将 dd,d 分别存入 dx 和 ax ,delphi到底按照什么顺序来处理参数d啊

Directive Parameter order Clean-upPasses parameters in registers?
register Left-to-right Routine Yes
pascal Left-to-right Routine No
cdecl Right-to-left Caller No
stdcall Right-to-left Routine No
safecall Right-to-left Routine No

参数传递方式:
Delphi中有自己的参数传递方式,而Windows API也有自己的参数传递方式,那么他们之间有什么不同呢,要如何做到兼容呢,尤其是在编写动态库时?
(1)cdecl:
通常是C/C++所使用的参数传递方式,它的传递方式是由右到左,而且当被调用的函数结束之后,将会由调用函数本身来清除堆栈上的参数数据.
(2)stdcall:
参数传递方式,也是由右到左,但是当被调用的函数结束之后,则是由被调用函数来清除堆栈上的参数数据,Win32API所有的输出函数都是采用此中参数传递方式
(3)pascal:
是Delphi1.0与win16API所使用的参数传递方式,它的传递方式是由左到右,而且由被调用函数来清除堆栈上的参数数据.
(4)fastcall:
是Delphi默认所使用的参数传递方式,此种方式在传递参数时把前三个参数放在CPU的EAX,EDX,ECX三个缓存器种,剩下的参数则会由左到右地被取出放到堆栈中,而当被调用的函数结束之后,则是由被调用函数来清除堆栈上的参数数据.
注:所以在引用C++动态库中的函数时,要注意参数的传递方式,一般使用stdcall.还要注意字符串类型,C++在传递字符串时,都是采用字符指针的类型(Char *),所以你在Delphi的程序中就必须使用PCHAR类型,而不是string类型.

Delphi编译代码和一般的C编译代码不太一样，比如调用约定中，C的thiscall用ECX传递this指针，而Delphi的thiscall用 EAX传递this指针；C的fastcall一般用ECX/EDX两个寄存器用于参数传递，而Delphi则用三个EAX/EDX/ECX；在使用浮点数时，C通过压栈两个DWORD传递double参数，而Delphi则用FLD和FSTP直接通过FPU传递参数。修饰名也不一样，这里不加叙述。

关于调用约定参考 http://baby.homeip.net/patrick/archives/000142.php

目前的IDA尚不支持加载.MAP/.SYM符号信息，根据DataRescue网站的说明，可以通过.IDC脚本加载（http://www.ccso.com/faq.html）。DeDe的IDA/Softice符号输出中据说可以自动检测运行的Soft-ICE并向其导入符号，但实际使用时不是很灵光，根据.MAP文件格式可以写一个程序将其转换成.IDC脚本：

#!/usr/bin/perl

use strict;

sub dump_idc;

my $hex_pat = "[0-9A-Fa-f]+";

my $start;

my @entries;

while (<>) {

chop;

if ($start eq ''--fetch-next'') {

# start, length, name, class

($start) = m/$hex_pat:($hex_pat)\s+($hex_pat)H\s+(\w+)\s+(\w+)/;

if (!$start) {

print STDERR "Invalid .map file format!";

exit -1;

}

$start = hex($start);

next;

}

if (m/Start\s+Length\s+Name\s+Class/) {

$start = ''--fetch-next'';

next;

}

if (m/$hex_pat:($hex_pat)\s*(.*)$/) {

my ($offset, $entry) = (hex($1), $2);

my $rva = $offset + $start;

push @entries, [$rva, $entry];

}

}

@entries = sort { $a->[0] cmp $b->[0] } @entries;

&dump_idc;

sub dump_idc {

print "static main() {\n";

foreach (@entries) {

my ($rva, $entry) = @$_;

#$rva = hex($rva);

$entry =~ s/^\*/\$/;

$entry =~ s/^[<>\-]*//;

$entry =~ s/\(.*$//;

$entry =~ s/:.*$//;

$entry =~ s/\./?/;

$entry =~ s/\[([0-9]+)\]/_$1/g;

$entry =~ s/\[.*$/_$rva/;

$entry =~ s/;.*$//;

$entry =~ s/^\s *//;

next if !$entry;

printf "MakeName(0x%x, \"$entry\");\n", $rva, $entry;

}

print "}\n";

}

1;

有些程序在检验注册码时通过抛出异常等行为确定是否注册成功，关于异常Matt Pietrek有一篇著名文章http://www.microsoft.com/msj/0197/Exception/Exception.aspx值得一读。从汇编代码上看，所有try/catch块都有类似的结构：

CODE:004BDE4C xor eax, eax

CODE:004BDE4E push ebp

CODE:004BDE4F push offset loc_4BDE92

CODE:004BDE54 push dword ptr fs:[eax] ; 保存上一个handler

CODE:004BDE57 mov fs:[eax], esp

CODE:004BDE92 loc_4BDE92:

CODE:004BDE92 jmp _Any2_Handler_DevErr?

CODE:004BDE97 jmp short loc_4BDE89

CODE:004BDEEA pop edx ; 上一个handler

CODE:004BDEEB pop ecx

CODE:004BDEEC pop ecx

CODE:004BDEED mov fs:[eax], edx ; 恢复

注意到4BDE97H处代码未被执行，这是怎么回事呢？原来它是finally对应的块，SEH内核会根据push offset loc_4BDE92自动得到4BDE97H的finally入口地址。因此在调试有异常处理的程序时，有时需要在handler和finally的处理程序处也设置断点。

今天先到这里，可能的话下次再贴。

在周爱民的著作《DELPHI源代码分析》中，对此有描述。

Khan's Notebook 2004-11-22 22:14 发表评论

昨天开始打算写cmpp3.0的网关,于是拿了华为的demo反编译了一下,发现n多汉字都编程了unicode编码,于是自己写了一个unicode转汉字的程序,share给大家

Khan's Notebook — Thu, 18 Nov 2004 21:44:00 GMT

几个转码的函数 unicode string utf8 anscii 之间的转换 delphi

/** 主程序,包含几个转码的函数

* 作者:刘昆

* 最后修改日期: 2004-11-18

* 以上代码免费,若直接引用一下代码请告知,并保留此注释

* 作为一名程序员应该有最基本的职业道德*/

unit MainForm;

interface

uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, StdCtrls, ExtCtrls;

type
TFormMain = class(TForm)
    Panel1: TPanel;
    Memo1: TMemo;
    ComboBox1: TComboBox;
    Button1: TButton;
    Memo2: TMemo;
    procedure Button1Click(Sender: TObject);
private
    function StrToUTF8(str: WideString): string;
    function StrToASC(Str: string): string;
    function GB2Unicode(Str: WideString): string; overload;
    //function GB2Unicode(Str: string): string; overload;
    function U2GB(Str: string): string;
    function UTF8ToStr(const str: UTF8String): string;
    function HexToInt(const Str: string): integer;
    function HexIndex(const c: Char): Integer;
    { Private declarations }
public
    { Public declarations }
end;

var
FormMain: TFormMain;

implementation

{$R *.dfm}

{ TFormMain }

function TFormMain.StrToASC(Str: string): string;
var
TmpStr: string;
TmpPchar: Pchar;
i: integer;
begin
result := '';
TmpStr := '';
TmpPchar := pchar(Str);
for i := 0 to length(TmpPchar) - 1 do
TmpStr := TmpStr + format('%2.2x', [ord(TmpPchar[i])]);

result := TmpStr;
end;

function TFormMain.StrToUTF8(str: WideString): string;
var
s: pchar;
i: integer;
tmp: string;
begin
tmp := '';
result := '';
s := pchar(Utf8encode(str));
for i := 0 to strlen(s) do begin
tmp := tmp + format('%2.2x', [ord(s[i])]);
end;
result := tmp;
end;

function TFormMain.UTF8ToStr(const str: UTF8String): string;
var
s: pchar;
i: integer;
tmp: string;
begin
tmp := '';
result := '';
s := PChar(str);
i := 0;
while i < length(s) do begin
tmp := tmp + chr(HexToInt(s[i] + s[i + 1]));
inc(i, 2);
end;
result := Utf8Decode(tmp);
end;

function TFormMain.GB2Unicode(Str: WideString): string;
var
i: Integer;
begin
Result := '';
for i := 1 to Length(Str) do
Result := Result + Format('%4.4x', [ord(Str[i])]);
end;

procedure TFormMain.Button1Click(Sender: TObject);
begin
case ComboBox1.ItemIndex of
    0: memo2.Lines.Add(GB2Unicode(memo1.Lines.Text));
    1: memo2.Lines.Add(StrToUTF8(memo1.Lines.Text));
    2: memo2.Lines.Add(UTF8ToStr(memo1.Lines.Text));
    3: memo2.Lines.Add(U2GB(StringReplace(memo1.Lines.Text, '\u', '', [rfReplaceAll])));
    4: memo2.Lines.Add(StrToASC(memo1.Lines.Text));
end;
end;

function TFormMain.HexToInt(const Str: string): integer;
var p: pchar;

begin
result := -1;
if length(str) > 2 then exit;
p := pchar(str);

if (HexIndex(p[0]) <> -1) and (HexIndex(p[1]) <> -1) then
result := HexIndex(p[0]) * $10 + HexIndex(p[1]);
end;

function TFormMain.HexIndex(const c: Char): Integer;
const Digits: array[0..15] of Char = ('0', '1', '2', '3', '4', '5', '6', '7', '8', '9', 'A', 'B', 'C', 'D', 'E', 'F');
var i: integer;
begin
result := -1;
if (not (UpCase(c) in ['0', '1', '2', '3', '4', '5', '6', '7', '8', '9', 'A', 'B', 'C', 'D', 'E', 'F'])) then
exit;

for i := 0 to high(digits) do
    if Digits[i] = UpCase(c) then begin
      result := i;
      break;
    end;
end;

function TFormMain.U2GB(Str: string): string;
var s: pchar;
i: integer;
tmp: string;
begin
tmp := '';
result := '';
s := PChar(str);
i := 0;
while i < length(s) do begin
tmp := tmp + chr(HexToInt(s[i + 2] + s[i + 3])) + chr(HexToInt(s[i] + s[i + 1]));//unicode转换时,高低位互换
inc(i, 4);
end;
result := widechartostring(pWideChar(tmp + #0#0#0#0));
end;

end.

Khan's Notebook 2004-11-19 05:44 发表评论

起因源于之前忘记一个adsl的端口,想写一个端口探测工具,止于sp的订购关系包检测

Khan's Notebook — Thu, 11 Nov 2004 19:25:00 GMT

虽然只有这么点东西,但我还是做了3天,老了

一个sp用的wap订购关系包调试检测工具

/** 程序的核心,一个post线程,用于提交xml数据包

* 作者:刘昆

* 最后修改日期: 2004-9-23

* 以上代码免费,若直接引用一下代码请告知,并保留此注释

* 作为一名程序员应该有最基本的职业道德*/

unit HTTPGetThread;

interface
uses classes, SysUtils, wininet, windows;

type
TOnProgressEvent = procedure(TotalSize, Readed: Integer) of object;

THTTPGetThread = class(TThread)

private
    FTAcceptTypes: string; //接收文件类型 *.*
    FTAgent: string; //浏览器名 Nokia6610/1.0 (5.52) Profile/MIDP-1.0 Configuration/CLDC-1.02
    FTURL: string; // url
    FTFileName: string; //文件名
    FTStringResult: AnsiString;
    FTUserName: string; //用户名
    FTPassword: string; //密码
    FTPostQuery: string; //方法名,post或者get
    FTReferer: string;
    FTBinaryData: Boolean;
    FTUseCache: Boolean; //是否从缓存读数据
    FTMimeType: string; //Mime类型

    FTResult: Boolean;
    FTFileSize: Integer;
    FTToFile: Boolean; //是否文件

BytesToRead, BytesReaded: LongWord;

    FTProgress: TOnProgressEvent;
    procedure ParseURL(URL: string; var HostName, FileName: string; var portNO: integer); //取得url的主机名和文件名
    procedure UpdateProgress;
protected
    procedure Execute; override;
public
    procedure setResult(FResult: boolean);
    function getResult(): boolean;
    function getFileName(): string;
    function getToFile(): boolean;
    function getFileSize(): integer;
    function getStringResult(): AnsiString;
    constructor Create(aAcceptTypes, aMimeType, aAgent, aURL, aFileName, aUserName, aPassword, aPostQuery, aReferer: string; aBinaryData, aUseCache: Boolean; aProgress: TOnProgressEvent; aToFile: Boolean);

end;

implementation

{ THTTPGetThread }

constructor THTTPGetThread.Create(aAcceptTypes, aMimeType, aAgent, aURL, aFileName, aUserName, aPassword, aPostQuery, aReferer: string; aBinaryData, aUseCache: Boolean; aProgress: TOnProgressEvent; aToFile: Boolean);
begin
FreeOnTerminate := True;
inherited Create(True);

FTAcceptTypes := aAcceptTypes;
FTAgent := aAgent;
FTURL := aURL;
FTFileName := aFileName;
FTUserName := aUserName;
FTPassword := aPassword;

//FTPostQuery := aPostQuery;

FTPostQuery := StringReplace(aPostQuery, #13#10, '', [rfReplaceAll]);

FTReferer := aReferer;
FTProgress := aProgress;
FTBinaryData := aBinaryData;
FTUseCache := aUseCache;
FTMimeType := aMimeType;

FTToFile := aToFile;
Resume;
end;

procedure THTTPGetThread.Execute;
var
hSession: hInternet; //回话句柄
hConnect: hInternet; //连接句柄
hRequest: hInternet; //请求句柄
Host_Name: string; //主机名
File_Name: string; //文件名
port_no: integer;

RequestMethod: PChar;
InternetFlag: longWord;
AcceptType: PAnsiChar;
dwBufLen, dwIndex: longword;
Buf: Pointer; //缓冲区
f: file;
Data: array[0..$400] of Char;
TempStr: AnsiString;
mime_Head: string;

procedure CloseHandles;
begin
    InternetCloseHandle(hRequest);
    InternetCloseHandle(hConnect);
    InternetCloseHandle(hSession);
end;

begin
inherited;
buf := nil;
try
try
ParseURL(FTURL, Host_Name, File_Name, port_no);

      if Terminated then begin
        FTResult := False;
        Exit;
      end;
     //建立会话
      hSession := InternetOpen(pchar(FTAgent), //lpszCallerName指定正在使用网络函数的应用程序
        INTERNET_OPEN_TYPE_PRECONFIG, //参数dwAccessType指定访问类型
        nil, //服务器名（lpszProxyName）。 accesstype为GATEWAY_PROXY_INTERNET_ACCESS和CERN_PROXY_ACCESS时
        nil, //NProxyPort参数用在CERN_PROXY_INTERNET_ACCESS中用来指定使用的端口数。使用INTERNET_INVALID_PORT_NUMBER相当于提供却省的端口数。
        0); //设置额外的选择。你可以使用INTERNET_FLAG_ASYNC标志去指示使用返回句句柄的将来的Internet函数将为回调函数发送状态信息，使用InternetSetStatusCallback进行此项设置

     //建立连接
      hConnect := InternetConnect(hSession, //会话句柄
        PChar(Host_Name), //指向包含Internet服务器的主机名称（如http://www.mit.edu）或IP地址（如202.102.13.141）的字符串
        port_no, //INTERNET_DEFAULT_HTTP_PORT, //是将要连结到的TCP/IP的端口号
        PChar(FTUserName), //用户名
        PChar(FTPassword), //密码
        INTERNET_SERVICE_HTTP, //协议
        0, // 可选标记，设置为INTERNET_FLAG_SECURE，表示使用SSL/PCT协议完成事务
        0); //应用程序定义的值，用来为返回的句柄标识应用程序设备场境

if FTPostQuery = '' then RequestMethod := 'GET'
else RequestMethod := 'POST';

if FTUseCache then InternetFlag := 0
else InternetFlag := INTERNET_FLAG_RELOAD;

AcceptType := PChar('Accept: ' + FTAcceptTypes);

    //建立一个http请求句柄
      hRequest := HttpOpenRequest(hConnect, //InternetConnect返回的HTTP会话句柄
        RequestMethod, //指向在申请中使用的"动词"的字符串，如果设置为NULL，则使用"GET"
        PChar(File_Name), //指向包含动词的目标对象名称的字符串，通常是文件名称、可执行模块或搜索说明符
        'HTTP/1.0', //指向包含HTTP版本的字符串，如果为NULL，则默认为"HTTP/1.0"；
        PChar(FTReferer), //指向包含文档地址（URL）的字符串，申请的URL必须是从该文档获取的
        @AcceptType, //指向客户接收的内容的类型
        InternetFlag,
        0);
      mime_Head := 'Content-Type: ' + FTMimeType;
      if FTPostQuery = '' then
        FTResult := HttpSendRequest(hRequest, nil, 0, nil, 0)
      else
    //发送一个指定请求到httpserver
        FTResult := HttpSendRequest(hRequest,
          pchar(mime_Head), //mime 头
          length(mime_Head), //头长度
          PChar(FTPostQuery), //附加数据缓冲区，可为空
          strlen(PChar(FTPostQuery))); //附加数据缓冲区长度

      if Terminated then
      begin
      //CloseHandles;
        FTResult := False;
        Exit;
      end;

      dwIndex := 0;
      dwBufLen := 1024;
      GetMem(Buf, dwBufLen);

    //接收header信息和一个http请求
      FTResult := HttpQueryInfo(hRequest,
        HTTP_QUERY_CONTENT_LENGTH,
        Buf, //指向一个接收请求信息的缓冲区的指针
        dwBufLen, //HttpQueryInfo内容的大小
        dwIndex); //读取的字节数

      if Terminated then begin
        FTResult := False;
        Exit;
      end;

      if FTResult or not FTBinaryData then begin //如果请求
        if FTResult then
          FTFileSize := StrToInt(StrPas(Buf));

BytesReaded := 0;

        if FTToFile then begin
          AssignFile(f, FTFileName);
          Rewrite(f, 1);
        end else FTStringResult := '';

        while True do begin
          if Terminated then begin
            FTResult := False;
            Exit;
          end;

          if not InternetReadFile(hRequest,
            @Data, //数据内容
            SizeOf(Data), //大小
            BytesToRead) //读取的字节数
            then Break
          else
            if BytesToRead = 0 then Break
            else begin
              if FTToFile then
                BlockWrite(f, Data, BytesToRead) //将读出的数据写入文件
              else begin
                TempStr := Data;
                SetLength(TempStr, BytesToRead);
                FTStringResult := FTStringResult + TempStr;
              end;

inc(BytesReaded, BytesToRead);

if Assigned(FTProgress) then //执行回调函数
Synchronize(UpdateProgress);

end;
end;

        if FTToFile then
          FTResult := FTFileSize = Integer(BytesReaded)
        else begin
         // SetLength(FTStringResult, BytesReaded);
          FTResult := BytesReaded <> 0;
        end;

      end;
    except
    end;
finally
    if FTToFile then CloseFile(f);

if assigned(Buf) then FreeMem(Buf);
CloseHandles;
end;
end;

function THTTPGetThread.getFileName: string;
begin
result := FTFileName;
end;

function THTTPGetThread.getFileSize: integer;
begin
result := FTFileSize;
end;

function THTTPGetThread.getResult: boolean;
begin
result := FTResult;
end;

function THTTPGetThread.getStringResult: AnsiString;
begin
result := FTStringResult;
end;

function THTTPGetThread.getToFile: boolean;
begin
result := FTToFile;
end;

procedure THTTPGetThread.ParseURL(URL: string; var HostName, FileName: string; var portNO: integer);
var
i: Integer;
begin
if Pos('http://', LowerCase(URL)) <> 0 then
Delete(URL, 1, 7);

i := Pos('/', URL);
HostName := Copy(URL, 1, i);
FileName := Copy(URL, i, Length(URL) - i + 1);

i := pos(':', hostName);
if i <> 0 then begin
portNO := strtoint(copy(hostName, i + 1, length(hostName) - i - 1));
hostName := copy(hostName, 1, i - 1);
end else portNO := 80;

if (Length(HostName) > 0) and (HostName[Length(HostName)] = '/') then SetLength(HostName, Length(HostName) - 1);
end;

procedure THTTPGetThread.setResult(FResult: boolean);
begin
FTResult := FResult;
end;

procedure THTTPGetThread.UpdateProgress;
begin
FTProgress(FTFileSize, BytesReaded);
end;

end.

/** 主要用来做线程和界面的交互

* 作者:刘昆

* 最后修改日期: 2004-9-23

* 以上代码免费,若直接引用一下代码请告知,并保留此注释

* 作为一名程序员应该有最基本的职业道德*/

unit MyHttpGet;

interface

uses HTTPGetThread, windows;

type
TOnDoneFileEvent = procedure(FileName: string; FileSize: Integer) of object;
TOnDoneStringEvent = procedure(Result: AnsiString) of object;

THttpGet = class
private
F_URL: string; //目标url
F_GetURLThread: THTTPGetThread; //取数据的线程

    F_Accept_Types: string;
    F_Agent: string;
    F_Binary_Data: Boolean;
    F_Use_Cache: Boolean; //是否读缓存
    F_File_Name: string;
    F_User_Name: string; //用户名
    F_Password: string; //密码
    F_PostQuery: string; //方法名
    F_Referer: string;
    F_Mime_Type: string;

F_Wait_Thread: Boolean;

FResult: Boolean;

    FProgress: TOnProgressEvent;
    FDoneFile: TOnDoneFileEvent;
    FDoneString: TOnDoneStringEvent;

procedure ThreadDone(Sender: TObject);

public
    constructor Create();
    destructor Destroy(); override;
    procedure getFile();
    procedure GetString();
    procedure Abort();
published
    property WaitThread: Boolean read F_Wait_Thread write F_Wait_Thread;
    property AcceptTypes: string read F_Accept_Types write F_Accept_Types;
    property Agent: string read F_Agent write F_Agent;
    property BinaryData: Boolean read F_Binary_Data write F_Binary_Data;
    property URL: string read F_URL write F_URL;
    property UseCache: Boolean read F_Use_Cache write F_Use_Cache;
    property FileName: string read F_File_Name write F_File_Name;
    property UserName: string read F_User_Name write F_User_Name;
    property Password: string read F_Password write F_Password;
    property PostQuery: string read F_PostQuery write F_PostQuery;
    property Referer: string read F_Referer write F_Referer;
    property MimeType: string read F_Mime_Type write F_Mime_Type;

property OnDoneFile: TOnDoneFileEvent read FDoneFile write FDoneFile;
property OnDoneString: TOnDoneStringEvent read FDoneString write FDoneString;
end;

implementation

{ THttpGet }

procedure THttpGet.Abort;
begin
if Assigned(F_GetURLThread) then
begin
F_GetURLThread.Terminate;
F_GetURLThread.setResult(false);
end;
end;

constructor THttpGet.Create;
begin
F_Accept_Types := '*/*';
F_Agent := 'Nokia6610/1.0 (5.52) Profile/MIDP-1.0 Configuration/CLDC-1.02';
end;

destructor THttpGet.Destroy;
begin

end;

procedure THttpGet.getFile;
var
Msg: TMsg;
begin
if not Assigned(F_GetURLThread) then
begin
    F_GetURLThread := THTTPGetThread.Create(F_Accept_Types,F_Mime_Type, F_Agent, F_URL, F_File_Name, F_User_Name, F_Password, F_PostQuery, F_Referer, F_Binary_Data, F_Use_Cache, FProgress, true);
    F_GetURLThread.OnTerminate := ThreadDone;
    if F_Wait_Thread then
      while Assigned(F_GetURLThread) do
        while PeekMessage(Msg, 0, 0, 0, PM_REMOVE) do
        begin
          TranslateMessage(Msg);
          DispatchMessage(Msg);
        end;
end
end;

procedure THttpGet.GetString;
var
Msg: TMsg;
begin
if not Assigned(F_GetURLThread) then
begin
    F_GetURLThread := THTTPGetThread.Create(F_Accept_Types,F_Mime_Type,F_Agent, F_URL, F_File_Name, F_User_Name, F_Password, F_PostQuery, F_Referer, F_Binary_Data, F_Use_Cache, FProgress, False);
    F_GetURLThread.OnTerminate := ThreadDone;
    if F_Wait_Thread then
      while Assigned(F_GetURLThread) do
        while PeekMessage(Msg, 0, 0, 0, PM_REMOVE) do begin
          TranslateMessage(Msg);
          DispatchMessage(Msg);
        end;
end
end;

procedure THttpGet.ThreadDone(Sender: TObject);
begin
FResult := F_GetURLThread.getResult;
if FResult then
    if F_GetURLThread.getToFile then begin
      if Assigned(FDoneFile) then FDoneFile(F_GetURLThread.getFileName, F_GetURLThread.getFileSize)
    end else
      if Assigned(FDoneString) then FDoneString(F_GetURLThread.getStringResult);

//end else if Assigned(FError) then FError(Self);
F_GetURLThread := nil;
end;

end.

/** 程序主界面

* 作者:刘昆

* 最后修改日期: 2004-9-23

* 以上代码免费,若直接引用一下代码请告知,并保留此注释

* 作为一名程序员应该有最基本的职业道德*/

unit MainForm;

interface

uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, StdCtrls, ExtCtrls, MyHttpGet;

type
TMain = class(TForm)
    Panel1: TPanel;
    Edit1: TEdit;
    Label1: TLabel;
    Panel2: TPanel;
    Panel3: TPanel;
    GroupBox1: TGroupBox;
    MeSend: TMemo;
    GroupBox2: TGroupBox;
    MeReceive: TMemo;
    Button1: TButton;
    CbSave: TCheckBox;
    Edit2: TEdit;
    Label2: TLabel;
    procedure Button1Click(Sender: TObject);
private
    { Private declarations }
    procedure onGetString(Result: AnsiString);
    procedure onGetFile(FileName: string; FileSize: Integer);

public
{ Public declarations }
end;

var
Main: TMain;

implementation

{$R *.dfm}

procedure TMain.Button1Click(Sender: TObject);
var hg: THttpGet;
strs: TStrings;
i: Integer;
begin
hg := nil;
strs := nil;
try
    strs := TStringList.Create;
    hg := THttpGet.Create;
    hg.WaitThread := false;
    hg.AcceptTypes := '*.*';

    hg.Agent := 'Nokia6610/1.0 (5.52) Profile/MIDP-1.0 Configuration/CLDC-1.02';
    hg.BinaryData := false;
    hg.URL := 'Http://' + Edit1.Text;
    hg.UseCache := false;
    hg.FileName := 'provison.xml';
    hg.UserName := '';
    hg.Password := '';

for i := 0 to MeSend.Lines.Count - 1 do
strs.Add(trim(MeSend.Lines[i]));

    hg.PostQuery := strs.Text;
    hg.Referer := 'Http://' + Edit1.Text; //text/plain
    hg.MimeType := Edit2.Text;
    hg.OnDoneString := onGetString;
    hg.OnDoneFile := onGetFile;

    hg.GetString;
finally
    strs.Free;
    hg.Free;
end;
end;

procedure TMain.onGetFile(FileName: string; FileSize: Integer);
begin

end;

procedure TMain.onGetString(Result: AnsiString);
begin
MeReceive.Lines.Text := Result;
end;

end.

Khan's Notebook 2004-11-12 03:25 发表评论

每个月都有那么几天让偶心烦,突然想做一个控制modem或者adsl modem发传真的东西

Khan's Notebook — Tue, 09 Nov 2004 13:45:00 GMT

传真,开源,object pascal,无第三方控件和class

原因就素因为我家里有一部传真机,我想把他当打印机用,仔细在网上找了一下,发现没有什么资料,只有一些软件或控件.

我发誓,要让这些把技术拽在手里饿死.

靠,能写个把软件了不起啊,

这个写完了以后,照旧开源,照旧不用第三方控件或class

Khan's Notebook 2004-11-09 21:45 发表评论

关于delphi的log的class已经完成,一如既往的open 他

Khan's Notebook — Tue, 09 Nov 2004 11:10:00 GMT

delphi ,日志class,临界区,文件操作

如果你引用或者修改以下代码请不要去掉注释,这个涉及到一个程序员的职业道德问题

转载请注明

/** 本代码为日志class

* 作者:刘昆

* 最后修改日期: 2004-9-23

* 以上代码免费,若直接引用一下代码请告知,并保留此注释

* 作为一名程序员应该有最基本的职业道德*/

unit pushLog;

interface

uses classes, sysutils, windows;

var
ThreadLock: TRTLCriticalSection; //临界区

const PathDelim = '\';
DriveDelim = ':';

type
Tlog = class
private
//logfile: file;
fileName: string;

    function dirExist(const DirName: string): boolean;
    function getDirName(const fileName: string): string;
    function LastDelimiter(const Delimiters, S: string): Integer;

procedure createLogDir();

public
constructor Create(const filename: string);
destructor Destroy(); override;

procedure addLog(p: Pchar);
end;

implementation

{ Tlog }

procedure Tlog.addLog(p: Pchar);
var log_Line: pchar;
log_len: integer;
handle: Thandle;
des_Len: longword;
begin
EnterCriticalSection(ThreadLock);
log_Line := nil;
handle := $0;
des_Len := $0;
try
    createLogDir;
    log_len := strlen(p);
    getmem(log_Line, log_len);
    strcopy(log_Line, p);

    handle := createfile(
      pchar(fileName), //文件名
      GENERIC_READ or GENERIC_WRITE, //期望存取模式通用读写
      FILE_SHARE_READ or FILE_SHARE_WRITE, //共享模式
      nil, //定义文件安全特性的指针（前提：操作系统支持）。
      OPEN_ALWAYS, //打开和创建文件方式。
      FILE_ATTRIBUTE_NORMAL or FILE_FLAG_RANDOM_ACCESS, //要打开文件的标志和属性（如：隐藏，系统等）。
      0); //模板文件句柄

    if handle <> INVALID_HANDLE_VALUE then begin
      SetFilePointer(handle, 0, nil, FILE_END);
      WriteFile(handle, log_Line^, log_len, des_Len, nil);

    end;
finally
    CloseHandle(handle);
    freeMem(log_Line);
    LeaveCriticalSection(ThreadLock);
end;
end;

constructor Tlog.Create(const filename: string);
begin
self.fileName := filename;
end;

procedure Tlog.createLogDir;
var dir_Name: string;
begin
dir_Name := getDirName(fileName) + '\log';
if not DirExist(dir_Name) then begin //检测日志目录是否存在
mkdir(dir_Name);
end;
end;

destructor Tlog.Destroy;
begin
inherited;
end;

function Tlog.DirExist(const DirName: string): boolean;
var
Handle: THandle;
FindData: TWin32FindData;
begin
result := false;
Handle := FindFirstFile(PChar(DirName), FindData);
if Handle <> INVALID_HANDLE_VALUE then begin
    FindClose(Handle);
    if (FindData.dwFileAttributes and FILE_ATTRIBUTE_DIRECTORY) = $10 then begin
      result := true;
    end;
end;
end;

function Tlog.getDirName(const fileName: string): string;
var
I: Integer;
begin
I := LastDelimiter(':\', Filename);
if (I > 1) and (FileName[I] = PathDelim) and (((FileName[I - 1] <> PathDelim) and (FileName[I - 1] <> DriveDelim)) or (ByteType(FileName, I - 1) = mbTrailByte)) then
Dec(I);
while (ByteType(FileName, I - 1) = mbTrailByte) and (I > 0) do
Dec(I);
Result := Copy(FileName, 1, I);
end;

function Tlog.LastDelimiter(const Delimiters, S: string): Integer;
var
P: PChar;
begin
Result := Length(S);
P := PChar(Delimiters);
while Result > 0 do
begin
    if (S[Result] <> #0) and (StrScan(P, S[Result]) <> nil) then // 检测最后一个字符是否为 '\'或者':'
      if (ByteType(S, Result) = mbTrailByte) then
        Dec(Result)
      else
        Exit;
    Dec(Result);
end;
end;

initialization
InitializeCriticalSection(ThreadLock);
finalization
DeleteCriticalSection(ThreadLock);
end.

调用方法

procedure TMain.Button1Click(Sender: TObject);
var
log: Tlog;
begin

log := Tlog.Create(ExtractFileDir(Application.Exename) + '\' + 'aa.log');
log.addLog(pchar('好的' + #13#10));
log.addLog(pchar('aaaaaaaaaaaaaaaaaaaa' + #13#10));
log.Free;
end;

Khan's Notebook 2004-11-09 19:10 发表评论

今天突然想写一个关于日志文件的class,用pascal,以前用java几简单,pascal的这块反而没有接触过

Khan's Notebook — Mon, 08 Nov 2004 13:27:00 GMT

delphi 日志 class

文本文件是由若干行组成的，若干个字符串组成一行，一行的结尾由回车换行符表示。如果对文本文件进行操作，则首先应通过调用AssignFile过程建立文件变量与外部文件的联系，并且使用Reset或ReWrite或Append方法打开。由于文本文件是以行为单位进行读写操作的，并且每一行的长度不一定相同，所以不能计算出指定行在文件中的准确位置，因此对于文件只能顺序的读写。要对文件进行读写操作，必须相应的对文件进行以读或写的方式打开，也就是对一个文本文件只能单独进行读或写的操作，而不能同时进行。

1、以添加方式打开文件(Append)

通过调用函数Append可打开一个已经存在的文件以便在文件末尾添加文本。如果在文件最后的128个字节块中，存在字符〈ctrl〉+〈z〉（ASCII26），那么文件将在字节处插入，并且覆盖该字符。

Append过程的声明如下：
procedure Append(var F:text);

其中F是一个任意文件类型的变量，并且必须同用AssignFile函数打开的外部文件相联系，如果指定的文件不存在，则会产生错误，如果指定的文件已经打开，则先关闭再重新打开。当前文件的位置设置在文件末尾。如果分配给F的是一个空名字，则在调用Append函数后，文件变量（F）将同将同标准输出文件建立联系。

2 、文本文件的读取和写入

文本文件通过调用过程Reset后以只读方式打开后，就可以使用Read或Readln过程来读取文件数据了。文本文件通过调用Write或Writeln过程来打开一文件后就可以使用或过程来写入数据。

(1) 用Read过程读取数据

通过调用Read过程可以从文本文件中读取或数字。其声明如下：
Procedure Read([var F:text;]v1 [,v2,…,vn,]);

其中F是一个文件变量，v1 ,v2,…,vn用于存储读取的数据，其必须为相同的类型。当v1 ,v2,…,vn定义为字符串型或字符型变量时，则Read过程将按照定义的长度读取字符。当v1 ,v2,…,vn定义为整数或实数变量时，则Read过程将以空格作为分隔符，如果在数字中出现逗号、分号或其他字符将产生异常。

(2) 用Readln过程读取数据

通过调用Readln 过程可以从文本文件中读取字符串、字符或数字，直到一行结束。其声明如下：
Procedure readln([var F:text;]v1 [,v2 ,…]);

其中F是一个文件变量，v1 ,v2,…,vn用于存储读取的数据

(3) 用Write过程写入数据

通过调用Write过程可以向文件中写入数据。其声明如下：
Procedure Write([var F:text;]p1[,p2,…]);

其中F是一个文件变量，p1 ,p2,…,pn用于存储写入的数据

(4) Writeln用过程写入数据

通过调用Writeln过程可以向文件中写入一行数据，并在结尾处输入回车符。声明如下：
Procedure Writeln([var F:text;]P1[,P2,…]):

3、文件的基本操作

对文本文件进行操作的基本函数与过程见表：

方法                                                                                  说明
Procedure AssignPrn(var F:text);                                       建立文本文件同打印机的联系
Function Eoln(var F:text):Boolean;                                   检测文件指针是否指向行尾
Procedure Flush(var F:text);                                             清空以输出方式（ReWite或Append）打开的文件缓冲区，以确保写入的文件字符都被写入外部文件
Function SeekEof(var F:text): boolean;                             返回文件尾状态
Function SeekEoln(var F:text):boolean;                             返回文件行尾状态
Procedure SetTextBuf(var F :text;var buf [;size:integer]); 设置文件缓冲区

Khan's Notebook 2004-11-08 21:27 发表评论