国产一区二区久久精品,在线精品亚洲,亚洲精品黄网在线观看

昨天玩delphi�U�程,扑ֈ�一��文�?强烈推荐大家看看,tthread代码分析

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

Delphi中的�U�程�c��?br />
转脓(chu��ng)�?华夏黑客同盟 http://www.77169.org

Delphi中有一个线�E�类TThread是用来实现多�U�程�~�程的，�q�个�l�大多数Delphi书藉都有说到�Q�但基本上都是对

TThread�cȝ��几个成员作一��单介�l�，再说明一下Execute的实现和Synchronize的用法就完了。然而这�q�不是多�U�程�~?br />�E�的全部�Q�我写此文的目的在于�Ҏ(gu��)��作一个补充�?/p>

�U�程本质上是�q�程中一�D��ƈ发运行的代码。一个进�E�至��有一个线�E�，��x��谓的�ȝ��E�。同时还可以有多个子�U�程�?br />当一个进�E�中用到��过一个线�E�时�Q�就是所谓的“多�U�程”�?br />那么�q�个所谓的“一�D�代码”是如何定义的呢�Q�其实就是一个函数或�q�程�Q�对Delphi而言�Q��?br />如果用Windows API来创建线�E�的话，是通过一个叫做CreateThread的API函数来实现的�Q�它的定义�ؓ(f��)�Q?br />HANDLE CreateThread(
    LPSECURITY_ATTRIBUTES lpThreadAttributes,
    DWORD dwStackSize,
    LPTHREAD_START_ROUTINE lpStartAddress,
    LPVOID lpParameter,
    DWORD dwCreationFlags,
    LPDWORD lpThreadId
);

其各参数如它们的名称所��_��分别是：�U�程属性（用于在NT下进行线�E�的安全属性设�|�，�?X下无效）�Q�堆栈大��，
起始地址�Q�参敎ͼ�创徏标志�Q�用于设�|�线�E�创建时的状态）�Q�线�E�ID�Q�最后返回线�E�Handle。其中的起始地址��是�U?br />�E�函数的入口�Q�直至线�E�函数结束，�U�程也就�l�束了�?/p>

因�ؓ(f��)CreateThread参数很多�Q�而且是Windows的API�Q�所以在C Runtime Library里提供了一个通用的线�E�函敎ͼ�理论�?br />可以在�Q何支持线�E�的OS中��用）�Q?br />unsigned long _beginthread(void (_USERENTRY *__start)(void *), unsigned __stksize, void *__arg);

Delphi也提供了一个相同功能的�c�M��函数�Q?br />function BeginThread(
    SecurityAttributes: Pointer;
    StackSize: LongWord;
    ThreadFunc: TThreadFunc;
    Parameter: Pointer;
    CreationFlags: LongWord;
    var ThreadId: LongWord
): Integer;

�q�三个函数的功能是基本相同的�Q�它们都是将�U�程函数中的代码攑ֈ�一个独立的�U�程中执行。线�E�函��C��一般函数的
最大不同在于，�U�程函数一启动�Q�这三个�U�程启动函数��p��回了�Q�主�U�程�l�箋向下执行�Q�而线�E�函数在一个独立的�U?br />�E�中执行�Q�它要执行多久，什么时候返回，�ȝ��E�是不管也不知道的�?br />正常情况下，�U�程函数�q�回后，�U�程��q��止了。但也有其它方式�Q?/p>

Windows API�Q?br />VOID ExitThread( DWORD dwExitCode );

C Runtime Library�Q?br />void _endthread(void);

Delphi Runtime Library�Q?br />procedure EndThread(ExitCode: Integer);

��Z��记录一些必要的�U�程数据�Q�状�?属性等�Q�，OS会�ؓ(f��)�U�程创徏一个内部Object�Q�如在Windows中那个Handle便是�q?br />个内部Object的Handle�Q�所以在�U�程�l�束的时候还应该释放�q�个Object�?/p>

虽然说用API或RTL(Runtime Library)已经可以很方便地�q�行多线�E�编�E�了�Q�但是还是需要进行较多的�l�节处理�Q��ؓ(f��)�?br />Delphi在Classes单元中对�U�程作了一个较好的��装�Q�这��是VCL的线�E�类�Q�TThread
使用�q�个�c�M��很简单，大多数的Delphi书籍都有��_��基本用法是：先从TThread�z��一个自��q��U�程�c�（因�ؓ(f��)TThread
是一个抽象类�Q�不能生成实例）�Q�然后是Override抽象�Ҏ(gu��)��Q�Execute�Q�这��是�U�程函数�Q�也��是在线�E�中执行的代�?br />部分�Q�，如果需要用到可视VCL对象�Q�还需要通过Synchronize�q�程�q�行。关于之斚w��的具体细节，�q�里不再赘述�Q�请
参考相关书�c��?/p>

本文接下来要讨论的是TThread�c�L��如何对线�E�进行封装的�Q�也��是深入研究一下TThread�cȝ��实现。因为只是真正地
了解了它�Q�才更好��C��用它�?br />下面是DELPHI7中TThread�cȝ��声明�Q�本文只讨论在Windows�q�_��下的实现�Q�所以去掉了所有有关Linux�q�_��部分的代�?br />�Q�：

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�c�d��Delphi的RTL里算是比较简单的�c�，�c�L��员也不多�Q�类属性都很简单明白，本文��只对几个比较重要的�c?br />成员�Ҏ(gu��)��和唯一的事�Ӟ��OnTerminate作详�l�分析�?br />首先��是构造函敎ͼ�
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;
虽然�q�个构造函数没有多��代码，但却可以��是最重要的一个成员，因�ؓ(f��)�U�程��是在这里被创徏的�?br />在通过Inherited调用TObject.Create后，�W�一句就是调用一个过�E�：AddThread�Q�其源码如下�Q?br />procedure AddThread;
begin
    InterlockedIncrement(ThreadCount);
end;

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

以加一��Z��来说明二者实现细节上的不同：
一般来��_��对内存数据加一的操作分解以后有三个步骤�Q?br />1�?从内存中��d��数据
2�?数据加一
3�?存入内存
现在假设在一个两个线�E�的应用中用Inc�q�行加一操作可能出现的一�U�情况：
1�?�U�程A从内存中��d��数据�Q�假设�ؓ(f��)3�Q?br />2�?�U�程B从内存中��d��数据�Q�也�?�Q?br />3�?�U�程A�Ҏ(gu��)��据加一�Q�现在是4�Q?br />4�?�U�程B�Ҏ(gu��)��据加一�Q�现在也�?�Q?br />5�?�U�程A��数据存入内存（现在内存中的数据�?�Q?br />6�?�U�程B也将数据存入内存�Q�现在内存中的数据还�?�Q�但两个�U�程都对它加了一�Q�应该是5才对�Q�所以这里出��C��
错误的结果）

而用InterlockIncrement�q�程则没有这个问题，因�ؓ(f��)所谓“原语”是一�U�不可中断的操作�Q�即操作�pȝ��能保证在一�?br />“原语”执行完毕前不会�q�行�U�程切换。所以在上面那个例子中，只有当线�E�A执行完将数据存入内存后，�U�程B才可
以开始从中取数�ƈ�q�行加一操作�Q�这样就保证了即使是在多�U�程情况下，�l�果也一定会是正��的�?/p>

前面那个例子也说明一�U�“线�E�访问冲�H�”的情况�Q�这也就是�ؓ(f��)什么线�E�之间需要“同步”（Synchronize�Q�，关于�q?br />个，在后面说到同步时�q�会再详�l�讨论�?/p>

说到同步�Q�有一个题外话�Q�加拿大滑铁卢大学的教授李明曑ְ�Synchronize一词在“线�E�同步”中被译作“同步”提�?br />�q�异议，个�h认�ؓ(f��)他说的其实很有道理。在中文中“同步”的意思是“同时发生”，而“线�E�同步”目的就是避免这
�U�“同时发生”的事情。而在英文中，Synchronize的意思有两个�Q�一个是传统意义上的同步�Q�To occur at the same
time�Q�，另一个是“协调一致”（To operate in unison�Q�。在“线�E�同步”中的Synchronize一词应该是指后面一�U?br />意思，即“保证多个线�E�在讉K��同一数据�Ӟ��保持协调一��_��避免出错”。不�q�像�q�样译得不准的词在IT业还有很�?br />�Q�既然已�l�是�U�定俗成了，本文也将�l�箋沿用�Q�只是在�q�里说明一下，因�ؓ(f��)软�g开发是一��细致的工作�Q�该弄清楚的
�Q�绝不能含糊�?/p>

扯远了，回到TThread的构造函��C��Q�接下来最重要��是�q�句了：
FHandle := BeginThread(nil, 0, @ThreadProc, Pointer(Self), CREATE_SUSPENDED, FThreadID);
�q�里��q��C��前面说到的Delphi RTL函数BeginThread�Q�它有很多参敎ͼ�关键的是�W�三、四两个参数。第三个参数��是
前面说到的线�E�函敎ͼ�卛_��U�程中执行的代码部分。第四个参数则是传递给�U�程函数的参敎ͼ�在这里就是创建的�U�程
对象�Q�即Self�Q�。其它的参数中，�W�五个是用于讄��U�程在创建后��x��P��不立��x��行（启动�U�程的工作是�?br />AfterConstruction中根据CreateSuspended标志来决定的�Q�，�W�六个是�q�回�U�程ID�?/p>

现在来看TThread的核心：�U�程函数ThreadProc。有意思的是这个线�E�类的核心却不是�U�程的成员，而是一个全局函数
�Q�因为BeginThread�q�程的参数约定只能用全局函数�Q�。下面是它的代码�Q?/p>

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中最重要的部分，因�ؓ(f��)�q�段代码是真正在�U�程中执行的代码。下面对代码�?br />逐行说明�Q?br />首先判断�U�程�cȝ��Terminated标志�Q�如果未被标志�ؓ(f��)�l�止�Q�则调用�U�程�cȝ��Execute�Ҏ(gu��)��执行�U�程代码�Q�因为TThread
是抽象类�Q�Execute�Ҏ(gu��)��是抽象方法，所以本质上是执行派生类中的Execute代码�?/p>

所以说�Q�Execute��是�U�程�c�M��的线�E�函敎ͼ�所有在Execute中的代码都需要当作线�E�代码来考虑�Q�如防止讉K��冲突�{��?br />如果Execute发生异常�Q�则通过AcquireExceptionObject取得异常对象�Q��ƈ存入�U�程�cȝ��FFatalException成员中�?br />最后是�U�程�l�束前做的一些收��ַ�作。局部变量FreeThread记录了线�E�类的FreeOnTerminated属性的讄��Q�然后将�U?br />�E�返回��D��|��ؓ(f��)�U�程�cȝ��q�回值属性的倹{��然后执行线�E�类的DoTerminate�Ҏ(gu��)��?/p>

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

很简单，��是通过Synchronize来调用CallOnTerminate�Ҏ(gu��)��Q�而CallOnTerminate�Ҏ(gu��)��的代码如下，��是��单地调用
OnTerminate事�g�Q?br />procedure TThread.CallOnTerminate;
begin
if Assigned(FOnTerminate) then FOnTerminate(Self);
end;

因�ؓ(f��)OnTerminate事�g是在Synchronize中执行的�Q�所以本质上它�ƈ不是�U�程代码�Q�而是�ȝ��E�代码（具体见后面对
Synchronize的分析）�?/p>

执行完OnTerminate后，��线�E�类的FFinished标志讄��为True。接下来执行SignalSyncEvent�q�程�Q�其代码如下�Q?br />procedure SignalSyncEvent;
begin
SetEvent(SyncEvent);
end;

也很��单，��是讄��一下一个全局Event�Q�SyncEvent�Q�关于Event的��用，本文��在后文详述�Q�而SyncEvent的用途将
在WaitFor�q�程中说明�?/p>

然后�Ҏ(gu��)��FreeThread中保存的FreeOnTerminate讄��军_��是否释放�U�程�c�，在线�E�类释放�Ӟ��q�有一些些操作�Q�详见接
下来的析构函数实现�?br />最后调用EndThread�l�束�U�程�Q�返回线�E�返回倹{��至此，�U�程完全�l�束�?br />说完构造函敎ͼ�再来看析构函敎ͼ�
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;

在线�E�对象被释放前，首先要检查线�E�是否还在执行中�Q�如果线�E�还在执行中�Q�线�E�ID不�ؓ(f��)0�Q��ƈ且线�E�结束标志未�?br />�|�）�Q�则调用Terminate�q�程�l�束�U�程。Terminate�q�程只是��单地讄��U�程�cȝ��Terminated标志�Q�如下面的代码：

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

所以线�E�仍然必��ȝ��l�执行到正常�l�束后才行，而不是立即终止线�E�，�q�一点要注意�?/p>

在这里说一炚w��外话�Q�很多�h都问�q�我�Q�如何才能“立即”终止线�E�（当然是指用TThread创徏的线�E�）。结果当然是
不行�Q�终止线�E�的唯一办法��是让Execute�Ҏ(gu��)��执行完毕�Q�所以一般来��_��要让你的�U�程能够��快�l�止�Q�必��d��
Execute�Ҏ(gu��)��中在较短的时间内不断地检查Terminated标志�Q�以便能及时地退出。这是设计线�E�代码的一个很重要的原
则！

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

如果�U�程处于启动挂�v状态，则将�U�程转入�q�行状态，然后调用WaitFor�q�行�{�待�Q�其功能��是�{�待到线�E�结束后才��
�l�向下执行。关于WaitFor的实玎ͼ��放到后面说明�?/p>

�U�程�l�束后，关闭�U�程Handle�Q�正常线�E�创建的情况下Handle都是存在的）�Q�释放操作系�l�创建的�U�程对象�?br />然后调用TObject.Destroy释放本对象，�q��攑ַ��l�捕��L(f��ng)��异常对象�Q�最后调用RemoveThread减小�q�程的线�E�数�?/p>

其它关于Suspend/Resume及线�E�优先��讄��{�方面，不是本文的重点，不再赘述。下面要讨论的是本文的另两个重点
�Q�Synchronize和W(xu��)aitFor�?/p>

但是在介�l�这两个函数之前�Q�需要先介绍另外两个�U�程同步技术：事�g和��(f��)界区�?/p>

事�g�Q�Event�Q�与Delphi中的事�g有所不同。从本质上说�Q�Event其实相当于一个全局的布?y��u)��(d��ng)变量。它有两个赋值操�?br />�Q�Set和Reset�Q�相当于把它讄��为True或False。而检查它的值是通过WaitFor操作�q�行。对应在Windows�q�_��上，是三
个API函数�Q�SetEvent、ResetEvent、WaitForSingleObject�Q�实现WaitFor功能的API�q�有几个�Q�这是最��单的一个）�?/p>

�q�三个都是原语，所以Event可以实现一般布?y��u)��(d��ng)变量不能实现的在多�U�程中的应用。Set和Reset的功能前面已�l�说�q�了
�Q�现在来说一下WaitFor的功能：

WaitFor的功能是��查Event的状态是否是Set状态（相当于True�Q�，如果是则立即�q�回�Q�如果不是，则等待它变�ؓ(f��)Set
状态，在等待期��_��调用WaitFor的线�E�处于挂��L(f��ng)��态。另外WaitFor有一个参数用于超时设�|�，如果此参��Cؓ(f��)0�Q�则�?br />�{�待�Q�立卌��回Event的状态，如果是INFINITE则无限等待，直到Set状态发生，若是一个有限的数��|��则等待相应的
毫秒数后�q�回Event的状态�?/p>

当Event从Reset状态向Set状态�{换时�Q�唤醒其它由于WaitFor�q�个Event而挂��L(f��ng)��U�程�Q�这��是它�ؓ(f��)什么叫Event的原
因。所谓“事件”就是指“状态的转换”。通过Event可以在线�E�间传递这�U�“状态�{换”信息�?/p>

当然用一个受保护�Q�见下面的��(f��)界区介绍�Q�的布尔变量也能实现�c�M��的功能，只要用一个��@环检查此布尔值的代码�?br />代替WaitFor卛_��。从功能上说完全没有问题�Q�但实际使用中就会发玎ͼ��q�样的等待会占用大量的CPU资源�Q�降低系�l?br />性能�Q�媄响到别的�U�程的执行速度�Q�所以是不经��的�Q�有的时候甚臛_��能会有问题。所以不��q�样用�?/p>

临界区（CriticalSection�Q�则是一��共享数据访问保护的技术。它其实也是相当于一个全局的布?y��u)��(d��ng)变量。但对它的操
作有所不同�Q�它只有两个操作�Q�Enter和Leave�Q�同样可以把它的两个状态当作True和False�Q�分别表�C�现在是否处于��(f��)
界区中。这两个操作也是原语�Q�所以它可以用于在多�U�程应用中保护共享数据，防止讉K��冲突�?/p>

用��(f��)界区保护�׃�n数据的方法很��单：在每�ơ要讉K��׃�n数据之前调用Enter讄��q�入临界区标志，然后再操作数据，
最后调用Leave��d��临界区。它的保护原理是�q�样的：当一个线�E�进入��(f��)界区后，如果此时另一个线�E�也要访问这个数
据，则它会在调用Enter�Ӟ��发现已经有线�E�进入��(f��)界区�Q�然后此�U�程��׃��被挂��P��{�待当前在��(f��)界区的线�E�调�?br />Leave��d��临界区，当另一个线�E�完成操作，调用Leave��d��后，此线�E�就会被唤醒�Q��ƈ讄��临界区标志，开始操作数
据，�q�样��防止了讉K��冲突�?/p>

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

现在再来看前面那个例子：
1. �U�程A�q�入临界区（假设数据�?�Q?br />2. �U�程B�q�入临界区，因�ؓ(f��)A已经在��(f��)界区中，所以B被挂�?br />3. �U�程A�Ҏ(gu��)��据加一�Q�现在是4�Q?br />4. �U�程A��d��临界区，唤醒�U�程B�Q�现在内存中的数据是4�Q?br />5. �U�程B被唤醒，�Ҏ(gu��)��据加一�Q�现在就�?了）
6. �U�程B��d��临界区，现在的数据就是正��的了�?/p>

临界区就是这样保护共享数据的讉K��?/p>

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

EnterCriticalSection
Try
// 操作临界区数�?br />Finally
LeaveCriticalSection
End;

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

�׃��在TThread中都是用API来操作Event和CriticalSection的，所以前面都是以API��Z��Q�其实Delphi已经提供了对�?br />们的��装�Q�在SyncObjs单元中，分别是TEvent�c�d��TCriticalSection�c�R��用法也与前面用API的方法相差无几。因�?br />TEvent的构造函数参数过多，��Z��单�v见，Delphi�q�提供了一个用默认参数初始化的Event�c�：TSimpleEvent�?/p>

��Z��再介�l�一下另一个用于线�E�同步的�c�：TMultiReadExclusiveWriteSynchronizer�Q�它是在SysUtils单元中定义的
。据我所知，�q�是Delphi RTL中定义的最长的一个类名，�q�好它有一个短的别名：TMREWSync。至于它的用处，我想�?br />看名字就可以知道了，我也��׃��多说了�?/p>

有了前面对Event和CriticalSection的准备知识，可以正式开始讨论Synchronize和W(xu��)aitFor了�?br />我们知道�Q�Synchronize是通过��部分代码放��C��U�程中执行来实现�U�程同步的，因�ؓ(f��)在一个进�E�中�Q�只有一个主�U�程
。先来看看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;

用于�q�行�U�程和主�U�程之间�q�行数据交换�Q�包括传入线�E�类对象�Q�同步方法及发生的异常�?br />在Synchronize中调用了它的一个重载版本，而且�q�个重蝲版本比较特别�Q�它是一个“类�Ҏ(gu��)��”。所谓类�Ҏ(gu��)��Q�是一�U?br />�Ҏ(gu��)��的类成员�Ҏ(gu��)��Q�它的调用�ƈ不需要创建类实例�Q�而是像构造函数那��P��通过�c�d��调用。之所以会用类�Ҏ(gu��)��来实�?br />它，是因��Zؓ(f��)了可以在�U�程对象没有创徏时也能调用它。不�q�实际中是用它的另一个重载版本（也是�c�L��法）和另一
个类�Ҏ(gu��)��StaticSynchronize。下面是�q�个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;

�q�段代码略多一些，不过也不��太复杂�?br />首先是判断当前线�E�是否是�ȝ��E�，如果是，则简单地执行同步�Ҏ(gu��)��后返回�?br />如果不是�ȝ��E�，则准备开始同步过�E��?br />通过局部变量SyncProc记录�U�程交换数据�Q�参敎ͼ�和一个Event Handle�Q�其记录�l�构如下�Q?br />TSyncProc = record
SyncRec: PSynchronizeRecord;
Signal: THandle;
end;

然后创徏一个Event�Q�接着�q�入临界区（通过全局变量ThreadLock�q�行�Q�因为同时只能有一个线�E�进入Synchronize�?br />态，所以可以用全局变量记录�Q�，然后��是把这个记录数据存入SyncList�q�个列表中（如果�q�个列表不存在的话，�?br />创徏它）。可见ThreadLock�q�个临界区就是�ؓ(f��)了保护对SyncList的访问，�q�一点在后面介绍CheckSynchronize时会�?br />�ơ看到�?/p>

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

接下来就是最主要的部分了�Q�调用WakeMainThread事�g�q�行同步操作。WakeMainThread是一个TNotifyEvent�c�d��的全
局事�g。这里之所以要用事件进行处理，是因为Synchronize�Ҏ(gu��)��本质上是通过消息�Q�将需要同步的�q�程攑ֈ��ȝ��E�中
执行�Q�如果在一些没有消息��@环的应用中（如Console或DLL�Q�是无法使用的，所以要使用�q�个事�g�q�行处理�?br />而响应这个事件的是Application对象�Q�下面两个方法分别用于设�|�和清空WakeMainThread事�g的响应（来自Forms单元�Q�：

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

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

上面两个�Ҏ(gu��)��分别是在TApplication�cȝ��构造函数和析构函数中被调用�?br />�q�就是在Application对象中WakeMainThread事�g响应的代码，消息��是在这里被发出的，它利用了一个空消息来实玎ͼ�

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

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

其中的CheckSynchronize也是定义在Classes单元中的�Q�由于它比较复杂�Q�暂时不详细说明�Q�只要知道它是具体处�?br />Synchronize功能的部分就好，现在�l�箋分析Synchronize的代码�?br />在执行完W(xu��)akeMainThread事�g后，��退��Z��(f��)界区�Q�然后调用WaitForSingleObject开始等待在�q�入临界区前创徏的那�?br />Event。这个Event的功能是�{�待�q�个同步�Ҏ(gu��)��的执行结束，关于�q�点�Q�在后面分析CheckSynchronize时会再说明�?br />注意在WaitForSingleObject之后又重新进入��(f��)界区�Q�但没有做�Q何事��退��Z��Q�似乎没有意义，但这是必��ȝ��Q?br />因�ؓ(f��)临界区的Enter和Leave必须严格的一一对应。那么是否可以改成这样呢�Q?/p>

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

上面的代码和原来的代码最大的区别在于把WaitForSingleObject也纳入��(f��)界区的限制中了。看上去没什么媄响，�q��
代码大大��化了�Q�但真的可以吗？
事实上是不行�Q?/p>

因�ؓ(f��)我们知道�Q�在Enter临界区后�Q�如果别的线�E�要再进入，则会被挂赗��而W(xu��)aitFor�Ҏ(gu��)��则会挂�v当前�U�程�Q�直到等
待别的线�E�SetEvent后才会被唤醒。如果改成上面那��L(f��ng)��代码的话�Q�如果那个SetEvent的线�E�也需要进入��(f��)界区的话
�Q�死锁（Deadlock�Q�就发生了（关于死锁的理论，误��行参考操作系�l�原理方面的资料�Q��?br />死锁是线�E�同步中最需要注意的斚w��之一�Q?br />最后释攑ּ�始时创徏的Event�Q�如果被同步的方法返回异常的话，�q�会在这里再�ơ抛出异常�?/p>

回到前面CheckSynchronize�Q�见下面的代码：

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;

首先�Q�这个方法必��d��ȝ��E�中被调用（如前面通过消息传递到�ȝ��E�）�Q�否则就抛出异常�?br />接下来调用ResetSyncEvent�Q�它与前面SetSyncEvent对应的，之所以不考虑WaitForSyncEvent的情况，是因为只有在
Linux版下才会调用带参数的CheckSynchronize�Q�W(xu��)indows版下都是调用默认参数0的CheckSynchronize�Q��?br />现在可以看出SyncList的用途了�Q�它是用于记录所有未被执行的同步�Ҏ(gu��)��的。因��Z��U�程只有一个，而子�U�程可能�?br />很多个，当多个子�U�程同时调用同步�Ҏ(gu��)��Ӟ��ȝ��E�可能一时无法处理，所以需要一个列表来记录它们�?br />在这里用一个局部变量LocalSyncList来交换SyncList�Q�这里用的也是一个原语：InterlockedExchange。同��P��q�里
也是用��(f��)界区��对SyncList的访问保护�v来�?br />只要LocalSyncList不�ؓ(f��)�I�，则通过一个��@环来依次处理累积的所有同步方法调用。最后把处理完的LocalSyncList�?br />放掉�Q�退��Z��(f��)界区�?/p>

再来看对同步�Ҏ(gu��)��的处理：首先是从列表中移出（取出�q�从列表中删除）�W�一个同步方法调用数据。然后退��Z��(f��)界区
�Q�原因当然也是�ؓ(f��)了防止死锁）�?br />接着��是真正的调用同步方法了�?br />如果同步�Ҏ(gu��)��中出现异常，��被捕获后存入同步方法数据记录中�?br />重新�q�入临界区后�Q�调用SetEvent通知调用�U�程�Q�同步方法执行完成了�Q�详见前面Synchronize中的
WaitForSingleObject调用�Q��?br />��x��Q�整个Synchronize的实��C��l�完成�?/p>

最后来说一下WaitFor�Q�它的功能就是等待线�E�执行结束。其代码如下�Q?br />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;

如果不是在主�U�程中执行W(xu��)aitFor的话�Q�很��单，只要调用WaitForSingleObject�{�待此线�E�的Handle为Signaled状�?br />卛_��?/p>

如果是在�ȝ��E�中执行W(xu��)aitFor则比较麻烦。首先要在Handle数组中增加一个SyncEvent�Q�然后��@环等待，直到�U�程�l?br />束（即MsgWaitForMultipleObjects�q�回WAIT_OBJECT_0�Q�详见MSDN中关于此API的说明）�?br />在��@环等待中作如下处理：如果有消息发生，则通过PeekMessage取出此消息（但�ƈ不把它从消息循环中移除）�Q�然�?br />调用MsgWaitForMultipleObjects来等待线�E�Handle或SyncEvent出现Signaled状态，同时监听消息�Q�QS_SENDMESSAGE
参数�Q�详见MSDN中关于此API的说明）。可以把此API当作一个可以同时等待多个Handle的WaitForSingleObject。如�?br />是SyncEvent被SetEvent�Q�返回WAIT_OBJECT_0 + 1�Q�，则调用CheckSynchronize处理同步�Ҏ(gu��)��?br />��Z��么在�ȝ��E�中调用WaitFor必须用MsgWaitForMultipleObjects�Q�而不能用WaitForSingleObject�{�待�U�程�l�束呢？
因�ؓ(f��)防止死锁。由于在�U�程函数Execute中可能调用Synchronize处理同步�Ҏ(gu��)��Q�而同步方法是在主�U�程中执行的�Q�如
果用WaitForSingleObject�{�待的话�Q�则�ȝ��E�在�q�里被挂��P��同步�Ҏ(gu��)��无法执行�Q�导致线�E�也被挂��P��于是发生死锁�?br />而改用WaitForMultipleObjects则没有这个问题。首先，它的�W�三个参��Cؓ(f��)False�Q�表�C�只要线�E�Handle或SyncEvent
中只要有一个Signaled卛_��使主�U�程被唤醒，至于加上QS_SENDMESSAGE是因为Synchronize是通过消息传到�ȝ��E�来�?br />�Q�所以还要防止消息被��d��。这��P��当线�E�中调用Synchronize�Ӟ��ȝ��E�就会被唤醒�q�处理同步调用，在调用完成后
�l�箋�q�入挂�v�{�待状态，直到�U�程�l�束�?br />��x��Q�对�U�程�c�TThread的分析可以告一个段落了�Q�对前面的分析作一个�ȝ��Q?br />1�?�U�程�cȝ��U�程必须按正常的方式�l�束�Q�即Execute执行�l�束�Q�所以在其中的代码中必须在适当的地方加入��够多
的对Terminated标志的判断，�q�及旉��出。如果必��要“立即”退出，则不能��用线�E�类�Q�而要改用API或RTL函数�?br />2�?对可视VCL的访问要攑֜�Synchronize中，通过消息传递到�ȝ��E�中�Q�由�ȝ��E�处理�?br />3�?�U�程�׃�n数据的访问应该用临界��行保护（当然用Synchronize也行�Q��?br />4�?�U�程通信可以采用Event�q�行�Q�当然也可以用Suspend/Resume�Q��?br />5�?当在多线�E�应用中使用多种�U�程同步方式�Ӟ��一定要��心防止出现死锁�?br />6�?�{�待�U�程�l�束要用WaitFor�Ҏ(gu��)��?/p>

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

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

最�q�一�D�|��间老弄Utf8�~�码,工作时写了几个函�?�l�大家指正一�?br>

//////////////////////////////////////////////
//---------取得utf8字符的长�?--------------//
//Str:String 源字�W�串
//Result:Integer utf8字符串长�?br>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;

////////////////////////////////////////////////
//----------取得字符串中的字�W�个�?-----------//
//str:String 源字�W�串
//Result:Integer 字符个数,兼容中文双字�?br>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 源字�W�串
//count:Integer 指定长度  一个汉字占三个字节,长度只能��?不能�?br>//Result:string 截取后的utf8字符�?br>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;  //英文转码后不能超�q�指定的位数
          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;  //汉字转码后不能超�q�指定的位数
               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 发表评论

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

首先需要写一个bookmark的xml文�g�Q�这个格式可以去nokia�|�站下蝲。下面是一个例子：




��量让name和url短点�Q�这��L(f��ng)��码后可以攑ֈ�一条短消息里面�Q�而不需要把一个设�|�拆分成多个短消息体。大致的一个封装是把xml文�g转成wbxml�Q�然后再在外面封装WSP层，最外面是WDP层�?/p>

WDP的一般格式是�?B0504C34FC002000304xxyy”，其中xx��是整个数据包的�ȝ��断数目，而yy表示当前片断是第几个片断。�D个例子，一个简单的bookmark全部攑֜�一个sms中这样xx�Q?1�Q�yy�Q?1�?br>下面是每个byte的意�?

bookmark的WSP层的格式一般是"01062D1F2A6170706C69636174696F6E2F782D7761702D70726F762E62726F777365722D626F6F6B6D61726B730081EA"
每个byte的具体意思是�Q?/p>

# 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�q�个文档�Q�里面很详细的描�q�C��每一个XML元素对应的十六进制。最后注意一点，发送的时候要�?bit格式的发送，而不�?bit格式�?br>

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

[SMS&WAP]实例讲解制作OTA短信来自动配�|�手机WAP书签[附源码]
摘要:OTA�Q�即Over The Air�Q�国内翻译�ؓ(f��)�I�Z��下蝲�?
OTA标准��q��立信和诺��Z��共同制订。OTA�늛�了许多范��_��比如Kjava中的应用�E�序下蝲也是通过OTA。我们这��文章主要讲的是�Q�通过短信方式�I�Z��下蝲配置信息�Q�参考的文档是OTA_settings_general_7_0.pdf�?
规范中定义了三种Setting�Q?
? ��览器设�|?
? ��览器的书签讄��
? SyncML讄��
也就是说�Q�你通过发送短信可以帮助用��h��机配�|�这三种讄��?

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

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

[导入]在偶机器上找��C��个读cpu串号的代�?delphi�?记录一�?��x��是�h家的代码)

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汇编有自己写�q�这些代码d,但是现在�q�了�q�么多年,退化到看不懂这些了

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

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

我把client的socket初始化内容写在了message响应函数里面�?每次触发消息的时候就把客��L(f��ng)��的socket�|?�?/p>

服务器端代码如下:

�׃��比较��?所以不贴注释了,如果有什么不懂d地方,大家对着��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 消息�l�构
    Msg: Cardinal; //�pȝ��消息
    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�l�定错误';
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 := '监听��p�|';
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�q�接的时�?�W�二个client的socket会覆盖前一个的,大家看情冉|��改就行了,�|�络上大把代码都是用控�g或者其他封装好d�c�L��写d,所以资料郁��h��?

客户端代�?

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); //初始化地址�I�间

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('��L��:' + Host + ' �q�接成功')
end else begin
Writeln('��L��:' + Host + ' �q�接��p�|');
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('接收消息��p�|!')
      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 的函数调用和参数传递方式深入研�I�之疑惑

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

希望大家帮忙解答. delphi的函�?的参��C��递方�?从我反汇�~�的代码来看好像不光是简单的压栈,涉及��C��多个寄存�?img src="http://blog.codelphi.com/liukun966123/aggbug/29380.aspx" height="1" width="1">

关于delphi 的函数调用和参数传递方式深入研�I?/p>

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 //初始化堆�?br>00407CAF   . 83C4 F0        ADD ESP,-10 //开�?0个字节的�?br>00407CB2   . B8 6C7C4000    MOV EAX,Project1.00407C6C
00407CB7   . E8 34C7FFFF    CALL Project1.004043F0
00407CBC   . 33C0           XOR EAX,EAX //EAX�?
00407CBE   . 55             PUSH EBP     //保存栈顶
00407CBF   . 68 037D4000    PUSH Project1.00407D03 //保存�q�回地址
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" //初始化局部变�?br>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 //�q�里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�?br>
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中有自己的参��C��递方�?而W(xu��)indows API也有自己的参��C��递方�?那么他们之间有什么不同呢,要如何做到兼容呢,��其是在�~�写动态库�?
(1)cdecl:
通常是C/C++所使用的参��C��递方�?它的传递方式是由右到左,而且当被调用的函数结束之�?��会��p��用函数本�w�来清除堆栈上的参数数据.
(2)stdcall:
参数传递方�?也是由右到左,但是当被调用的函数结束之�?则是��p��调用函数来清除堆栈上的参数数�?Win32API所有的输出函数都是采用此中参数传递方�?
(3)pascal:
是Delphi1.0与win16API所使用的参��C��递方�?它的传递方式是由左到右,而且��p��调用函数来清除堆栈上的参数数�?
(4)fastcall:
是Delphi默认所使用的参��C��递方�?此种方式在传递参数时把前三个参数攑֜�CPU的EAX,EDX,ECX三个�~�存器种,剩下的参数则会由左到叛_��被取出放到堆栈中,而当被调用的函数�l�束�? �?则是��p��调用函数来清除堆栈上的参数数�?
�?所以在引用C++动态库中的函数�?要注意参数的传递方�?一般��用stdcall.�q�要注意字符串类�?C++在传递字�W�串�?都是采用字符指针�? �c�d��(Char *),所以你在Delphi的程序中��必 ��M��用PCHAR�c�d��,而不是string�c�d��.

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

关于调用�U�定参�?http://baby.homeip.net/patrick/archives/000142.php

目前的IDA��不支持加蝲.MAP/.SYM�W�号信息�Q�根据DataRescue�|�站的说明，可以通过.IDC脚本加蝲�Q?a target="_new" >http://www.ccso.com/faq.html�Q�。DeDe的IDA/Softice�W�号输出中据说可以自动检��运行的Soft-ICE�q�向其导入符��P��但实际��用时不是很灵光，�Ҏ(gu��)��.MAP文�g格式可以写一个程序将其�{换成.IDC脚本�Q?

#!/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;

有些�E�序在检验注册码旉��过抛出异常�{�行为确定是否注册成功，关于异常Matt Pietrek有一��著名文�?a target="_new" >http://www.microsoft.com/msj/0197/Exception/Exception.aspx值得一�?/a>。从汇编代码上看�Q�所有try/catch块都有类似的�l�构�Q?

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 ; 恢复

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

今天先到�q�里�Q�可能的话下�ơ再贴�?

在周爱民的著作《DELPHI源代码分析》中�Q�对此有描述�?br>

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

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

几个转码的函�?unicode string utf8 anscii 之间的�{�?delphi

/** �ȝ��?包含几个转码的函�?/font>

* 作�?刘昆

* 最后修�Ҏ(gu��)��? 2004-11-18

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

* 作�ؓ(f��)一名程序员应该有最基本的职业道�?/

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转换�?高低位互�?br> inc(i, 4);
end;
result := widechartostring(pWideChar(tmp + #0#0#0#0));
end;

end.

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

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

虽然只有�q�么点东�?但我�q�是做了3�?老了

一个sp用的wap订购关系包调试检��工�?img src="http://blog.codelphi.com/liukun966123/aggbug/28600.aspx" height="1" width="1">

/** �E�序的核�?一个post�U�程,用于提交xml数据�?/font>

* 作�?刘昆

* 最后修�Ҏ(gu��)��? 2004-9-23

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

* 作�ؓ(f��)一名程序员应该有最基本的职业道�?/

unit HTTPGetThread;

interface
uses classes, SysUtils, wininet, windows;

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

THTTPGetThread = class(TThread)

private
    FTAcceptTypes: string; //接收文�g�c�d�� *.*
    FTAgent: string; //��览器名 Nokia6610/1.0 (5.52) Profile/MIDP-1.0 Configuration/CLDC-1.02
    FTURL: string; // url
    FTFileName: string; //文�g�?br>    FTStringResult: AnsiString;
    FTUserName: string; //用户�?br>    FTPassword: string; //密码
    FTPostQuery: string; //�Ҏ(gu��)��?post或者get
    FTReferer: string;
    FTBinaryData: Boolean;
    FTUseCache: Boolean; //是否从缓存读数据
    FTMimeType: string; //Mime�c�d��

    FTResult: Boolean;
    FTFileSize: Integer;
    FTToFile: Boolean; //是否文�g

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; //�q�接句柄
hRequest: hInternet; //��h��句柄
Host_Name: string; //��L��?br> File_Name: string; //文�g�?br> port_no: integer;

RequestMethod: PChar;
InternetFlag: longWord;
AcceptType: PAnsiChar;
dwBufLen, dwIndex: longword;
Buf: Pointer; //�~�冲�?br> 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指定正在使用�|�络函数的应用程�?br>        INTERNET_OPEN_TYPE_PRECONFIG, //参数dwAccessType指定讉K��c�d��
        nil, //服务器名�Q�lpszProxyName�Q��?accesstype为GATEWAY_PROXY_INTERNET_ACCESS和CERN_PROXY_ACCESS�?br>        nil, //NProxyPort参数用在CERN_PROXY_INTERNET_ACCESS中用来指定��用的端口数。��用INTERNET_INVALID_PORT_NUMBER相当于提供却省的端口数�?br>        0); //讄��额外的选择。你可以使用INTERNET_FLAG_ASYNC标志��L��C�Z��用返回句句柄的将来的Internet函数��ؓ(f��)回调函数发送状态信息，使用InternetSetStatusCallback�q�行此项讄��

     //建立�q�接
      hConnect := InternetConnect(hSession, //会话句柄
        PChar(Host_Name), //指向包含Internet服务器的��L��名称�Q�如http://www.mit.edu�Q�或IP地址�Q�如202.102.13.141�Q�的字符�?br>        port_no, //INTERNET_DEFAULT_HTTP_PORT, //是将要连�l�到的TCP/IP的端口号
        PChar(FTUserName), //用户�?br>        PChar(FTPassword), //密码
        INTERNET_SERVICE_HTTP, //协议
        0, // 可选标讎ͼ�讄��为INTERNET_FLAG_SECURE�Q�表�C�Z��用SSL/PCT协议完成事务
        0); //应用�E�序定义的��|��用来��回的句柄标识应用�E�序讑֤�场境

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

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

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

    //建立一个http��h��句柄
      hRequest := HttpOpenRequest(hConnect, //InternetConnect�q�回的HTTP会话句柄
        RequestMethod, //指向在申请中使用�?动词"的字�W�串�Q�如果设�|��ؓ(f��)NULL�Q�则使用"GET"
        PChar(File_Name), //指向包含动词的目标对象名�U�的字符�Ԍ��通常是文件名�U�、可执行模块或搜索说明符
        'HTTP/1.0', //指向包含HTTP版本的字�W�串�Q�如果�ؓ(f��)NULL�Q�则默认�?HTTP/1.0"�Q?br>        PChar(FTReferer), //指向包含文档地址�Q�URL�Q�的字符�Ԍ��甌��的URL必须是从该文档获取的
        @AcceptType, //指向客户接收的内容的�c�d��
        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 �?br>          length(mime_Head), //头长�?br>          PChar(FTPostQuery), //附加数据�~�冲区，可�ؓ(f��)�I?br>          strlen(PChar(FTPostQuery))); //附加数据�~�冲区长�?/font>

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

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

    //接收header信息和一个http��h��
      FTResult := HttpQueryInfo(hRequest,
        HTTP_QUERY_CONTENT_LENGTH,
        Buf, //指向一个接收请求信息的�~�冲区的指针
        dwBufLen, //HttpQueryInfo内容的大��?br>        dwIndex); //��d��的字节数

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

      if FTResult or not FTBinaryData then begin //如果��h��
        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) //��d��的字节数
            then Break
          else
            if BytesToRead = 0 then Break
            else begin
              if FTToFile then
                BlockWrite(f, Data, BytesToRead) //��读出的数据写入文�g
              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.

/** 主要用来做线�E�和界面的交�?/font>

* 作�?刘昆

* 最后修�Ҏ(gu��)��? 2004-9-23

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

* 作�ؓ(f��)一名程序员应该有最基本的职业道�?/

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; //取数据的�U�程

    F_Accept_Types: string;
    F_Agent: string;
    F_Binary_Data: Boolean;
    F_Use_Cache: Boolean; //是否�ȝ��?br>    F_File_Name: string;
    F_User_Name: string; //用户�?br>    F_Password: string; //密码
    F_PostQuery: string; //�Ҏ(gu��)��?br>    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.

/** �E�序�ȝ��?/font>

* 作�?刘昆

* 最后修�Ҏ(gu��)��? 2004-9-23

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

* 作�ؓ(f��)一名程序员应该有最基本的职业道�?/

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 发表评论

每个月都有那么几天让偶心�?�H�然惛_��一个控制modem或者adsl modem发传真的东西

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

传真,开�?object pascal,无第三方控�g和class

原因��q��因�ؓ(f��)我家里有一部传真机,我想把他当打印机�?仔细在网上找了一�?发现没有什么资�?只有一些��Y件或控�g.

我发�?要让�q�些把技术拽在手里饿�?

�?能写个把软�g了不起啊,

�q�个写完了以�?照旧开�?照旧不用�W�三�Ҏ(gu��)��件或class

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

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

delphi ,日志class,临界�?文�g操作

如果你引用或者修改以下代�?请不要去掉注�?�q�个涉及��C��个程序员的职业道德问�?/p>

转蝲��h��?/p>

/** 本代码�ؓ(f��)日志class

* 作�?刘昆

* 最后修�Ҏ(gu��)��? 2004-9-23

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

* 作�ؓ(f��)一名程序员应该有最基本的职业道�?/

unit pushLog;

interface

uses classes, sysutils, windows;

var
ThreadLock: TRTLCriticalSection; //临界�?/p>

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), //文�g�?br>      GENERIC_READ or GENERIC_WRITE, //期望存取模式通用��d��
      FILE_SHARE_READ or FILE_SHARE_WRITE, //�׃�n模式
      nil, //定义文�g安全�Ҏ(gu��)��的指针�Q�前提：操作�pȝ��支持�Q��?br>      OPEN_ALWAYS, //打开和创建文件方式�?br>      FILE_ATTRIBUTE_NORMAL or FILE_FLAG_RANDOM_ACCESS, //要打开文�g的标志和属性（如：隐藏�Q�系�l�等�Q��?br>      0); //模板文�g句柄

    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 //��日志目录是否存�?br> 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 // ��最后一个字�W�是否�ؓ(f��) '\'或�?:'
      if (ByteType(S, Result) = mbTrailByte) then
        Dec(Result)
      else
        Exit;
    Dec(Result);
end;
end;

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

调用�Ҏ(gu��)��

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 发表评论

今天�H�然惛_��一个关于日志文件的class,用pascal,以前用java几简�?pascal的这块反而没有接触过

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

delphi 日志 class

文本文�g是由若干行组成的�Q�若�q�个字符串组成一行，一行的�l�尾由回车换行符表示。如果对文本文�g�q�行操作�Q�则首先应通过调用AssignFile�q? �E�徏立文件变量与外部文�g的联�p�，�q�且使用Reset或ReWrite或Append�Ҏ(gu��)��打开。由于文本文件是以行为单位进行读写操作的�Q��ƈ且每一行的�? 度不一定相同，所以不能计��出指定行在文�g中的准确位置�Q�因此对于文件只能顺序的��d��。要�Ҏ(gu��)��件进行读写操作，必须相应的对文�g�q�行以读或写的方式打开�Q? 也就是对一个文本文件只能单独进行读或写的操作，而不能同时进行�?/p>

1�?以添加方式打开文�g(Append)

通过调用函数Append可打开一个已�l�存在的文�g以便在文件末��添加文本。如果在文�g最后的128个字节块中，存在字符〈ctrl�?〈z〉（ASCII26�Q�，那么文�g��在字节处插入，�q�且覆盖该字�W��?/p>

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

�? 中F是一个�Q意文件类型的变量�Q��ƈ且必��d��用AssignFile函数打开的外部文件相联系�Q�如果指定的文�g不存在，则会产生错误�Q�如果指定的文�g已经�? 开�Q�则先关闭再重新打开。当前文件的位置讄��在文件末��。如果分配给F的是一个空名字�Q�则在调用Append函数后，文�g变量�Q�F�Q�将同将同标准输出文�? 建立联系�?/p>

2 、文本文件的��d��和写�?/p>

文本文�g通过调用�q�程Reset后以只读方式打开后，��可以��用Read或Readln�q�程来读取文件数据了。文本文仉��过调用Write或Writeln�q�程来打开一文�g后就可以使用或过�E�来写入数据�?/p>

(1) 用Read�q�程��d��数据

通过调用Read�q�程可以从文本文件中��d��或数字。其声明如下�Q?br>Procedure Read([var F:text;]v1 [,v2,�?vn,]);

�? 中F是一个文件变量，v1 ,v2,�?vn用于存储��d��的数据，其必��Mؓ(f��)相同的类型。当v1 ,v2,�?vn定义为字�W�串型或字符型变量时�Q�则Read�q�程��按照定义的长度��d��字符。当v1 ,v2,�?vn定义为整数或实数变量�Ӟ��则Read�q�程��以�I�格作�ؓ(f��)分隔�W�，如果在数字中出现逗号、分��h��其他字符��生异常�?/p>

(2) 用Readln�q�程��d��数据

通过调用Readln �q�程可以从文本文件中��d��字符丌Ӏ�字�W�或数字�Q�直��C��行结束。其声明如下�Q?br>Procedure readln([var F:text;]v1 [,v2 ,…]);

其中F是一个文件变量，v1 ,v2,�?vn用于存储��d��的数�?/p>

(3) 用Write�q�程写入数据

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

其中F是一个文件变量，p1 ,p2,�?pn用于存储写入的数�?/p>

(4) Writeln用过�E�写入数�?/p>

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

3�?文�g的基本操�?/p>

�Ҏ(gu��)��本文件进行操作的基本函数与过�E�见表：

�Ҏ(gu��)��                                                                                  说明
Procedure AssignPrn(var F:text);                                       建立文本文�g同打印机的联�p?nbsp;
Function Eoln(var F:text):Boolean;                                   ��文件指针是否指向行��?nbsp;
Procedure Flush(var F:text);                                             清空以输出方式（ReWite或Append�Q�打开的文件缓冲区�Q�以��保写入的文件字�W�都被写入外部文�?nbsp;
Function SeekEof(var F:text): boolean;                             �q�回文�g��?nbsp;
Function SeekEoln(var F:text):boolean;                             �q�回文�g行尾状�?nbsp;
Procedure SetTextBuf(var F :text;var buf [;size:integer]); 讄��文�g�~�冲�?/p>

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

国产一区二区久久精品,在线精品亚洲,亚洲精品黄网在线观看

昨天玩delphi�U�程,扑ֈ�一���文�?强烈推荐大家看看,tthread代码分析

[导入]在偶机器上找��C��个读cpu串号的代�?delphi�?记录一�?��x��是�h家的代码)

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

每个月都有那么几天让偶心�?�H�然惛_��一个控制modem或者adsl modem发传真的东西

今天�H�然惛_��一个关于日志文件的class,用pascal,以前用java几简�?pascal的这块反而没有接触过

昨天玩delphi�U�程,扑ֈ�一��文�?强烈推荐大家看看,tthread代码分析