fax.pas

< Delphi网络通信协议分析与应用实现>>一书的源代码。

    DeviceName: Array[0..80] of Char;
    DCB: TDCB;
    Config : String;
    CommTimeouts : TCommTimeouts;
begin
    if FStatus in [fsIdle, fsAborted] then
    begin
        StrPCopy(DeviceName, GetDeviceName(FFaxDevice));
        ComFile := CreateFile(DeviceName, GENERIC_READ or GENERIC_WRITE, 0, Nil,
            OPEN_EXISTING, FILE_ATTRIBUTE_NORMAL, 0);
        if ComFile = INVALID_HANDLE_VALUE then
            RaiseException('Unable to open '
                    + GetDeviceName(FFaxDevice));
        ChangeStatus(fsDeviceOpen);
        try
            if not SetupComm(ComFile, RxBufferSize, TxBufferSize) then
                RaiseException('Error allocating serial I/O buffers');
            if not GetCommState(ComFile, DCB) then
                RaiseException('GetCommState call failed');
            DCB.Flags := 0;
            Config := 'baud=19200 parity=n data=8 stop=1' + NUL;
            if not BuildCommDCB(@Config[1], DCB) then
                RaiseException('BuildCommDCB call failed');
            if  FFlowControl = fcCTS then
                DCB.Flags := DCB.Flags or 4
            else if  FFlowControl = fcDSR then
                DCB.Flags := DCB.Flags or 8
            else if FFlowCOntrol = fcXOFF then
            begin
                DCB.Flags := DCB.Flags or $100;
                DCB.XOnChar := XON;
                DCB.XOffChar := XOFF;
            end;
            if not SetCommState(ComFile, DCB) then
                RaiseException('SetCommState call failed');
            with CommTimeouts do
            begin
                ReadIntervalTimeout := 0;
                ReadTotalTimeoutMultiplier := 0;
                ReadTotalTimeoutConstant := 1;
                WriteTotalTimeoutMultiplier := 0;
                WriteTotalTimeoutConstant := DataWriteTimeout;
            end;
            if not SetCommTimeouts(ComFile, CommTimeouts) then
                RaiseException('SetCommTimeouts call failed');
            if not EscapeCommFunction(ComFile, SETDTR) then
                RaiseException('Error raising DTR signal');
            if not EscapeCommFunction(ComFile, SETRTS) then
                RaiseException('Error raising RTS signal');
        except
            ChangeStatus(fsIdle);
            if ComFile <> INVALID_HANDLE_VALUE then CloseHandle(ComFile);
        end;
    end;
end;

{ Send string to the communications port }

procedure TFax.SendString(s: String);
var
    BytesWritten: DWORD;
begin
    if Assigned(FOnCommTransmit) then FOnCommTransmit(Self, s);
    if not WriteFile (ComFile, s[1], Length(s), BytesWritten, Nil) then
        RaiseException('Error writing to communications port');
end;

{ Flush the communications buffers }

procedure TFax.FlushBuffers;
begin
    PurgeComm(ComFile, PURGE_TXCLEAR or PURGE_RXCLEAR);
end;

{ Raises an exception if the modem response contains a hangup command that
  specifies an error has occurred. }

procedure TFax.CheckHangup(Response: String);
var
    i, ResultCode: Integer;
    ResultStr, ErrorStr: String;
begin
    i := Pos(HangupRsp, Response) + Length(HangupRsp);
    ResultStr := '';
    while (i <= Length(Response)) and (Response[i] in ['0'..'9', ' ']) do
    begin
        if Response[i] <> ' ' then ResultStr := ResultStr + Response[i];
        i := i + 1;
    end;
    ResultCode := StrToIntDef(ResultStr, 0);
    if ResultCode <> 0 then
    begin
        ErrorStr := 'Error ' + ResultStr;
        for i := Low(HangupCodes) to High(HangupCodes) do
            if HangupCodes[i].Code = ResultCode then
                ErrorStr := HangupCodes[i].Msg;
            RaiseException('Modem hangup: ' + ErrorStr);
    end;
end;

{ Retrieve a line of data from communications device.
  Returns null string if no data present.
  Raises an exception if modem hangs up with an error status. }

function TFax.ReceiveString: String;
var
    BytesRead: DWORD;
    Ch: Char;
    S: String;
begin
    Result := '';
    repeat
        if not ReadFile (ComFile, Ch, 1, BytesRead, Nil) then
            RaiseException('Error reading from communications port');
        if Ch <> LF then Result := Result + Ch;
    until (BytesRead = 0) or (Ch = CR);
    if Assigned(FOnCommReceive) and (Length(Result) > 0) then
        FOnCommReceive(Self, Result);
    if Pos(HangUpRsp, Result) <> 0 then CheckHangup(Result);
end;

{ Send command to communications port. Waits for command to echo.
  Raises an exception if an error occurs. }

procedure TFax.SendCommand(s: String);
var
    Command: String;
    GotResponse: Boolean;
    Retries: Integer;
begin
    Command := CommandPrefix + s;
    FlushBuffers;
    SendString(Command + CommandSuffix);
    Sleep(CommandEchoWait);
    GotResponse := False;
    Retries := 0;
    while not GotResponse and (Retries < CommandEchoTries) do
    begin
        if Copy(ReceiveString, 1, Length(Command)) = Command then
            GotResponse := True
        else begin
            Application.ProcessMessages;
            if FStatus = fsAborted then Exit;
            Sleep(CommandEchoWait);
            Retries := Retries + 1;
        end;
    end;
    if not GotResponse then
        RaiseException('Timeout waiting for command echo: ' +
            CommandPrefix + s);
end;

{ Strip non-printable characters from a string }

function TFax.StripNonPrintable(s: String): String;
var
    i: Integer;
begin
    Result := '';
    for i := 1 to Length(s) do if (Ord(s[i]) >= 32) and (Ord(s[i]) <= 127) then
        Result := Result + s[i];
end;

{ Wait for command response. Non-printable characters are stripped so function
  only returns when response is available.
  Exception is raised if operation times out. }

function TFax.ReceiveResponse(Retries, WaitTime: integer): String;
var
    GotResponse: Boolean;
    RetryCount: Integer;
begin
    GotResponse := False;
    RetryCount := 0;
    while not GotResponse and (RetryCount < Retries) do
    begin
        Result := StripNonPrintable(ReceiveString);
        if Length(Result) > 0 then
            GotResponse := True
        else begin
            Application.ProcessMessages;
            if FStatus = fsAborted then Exit;
            Sleep(WaitTime);
            RetryCount := RetryCount + 1;
        end;
    end;
    if not GotResponse then
        RaiseException('No response from modem');
end;

{ Return true if the modem response (comma seperated) contains the
  nominated string. }

function TFax.FindResult(ModemResponse, SearchString: String): Boolean;
var
    i: Integer;
    CurStr: String;
begin
    Result := False;
    CurStr := '';
    i := 0;
    while (i < Length(ModemResponse)) and not Result do
    begin
        i := i + 1;
        if  ModemResponse[i] in ['0'..'9', '.'] then
            CurStr := CurStr + ModemResponse[i];
        if (ModemResponse[i] = ',') or (i = Length(ModemResponse)) then
        begin
            Result := (CurStr = SearchString);
            CurStr := '';
        end;
    end;
end;

{ Check that modem is switched on and capable of performing class 2 operation.
  Raise an exception if it is not. }

procedure TFax.CheckModemClass;
var
    Response: String;
begin
    SendCommand(EstablishClassCmd);
    Response := ReceiveResponse(CommandResponseTries, CommandResponseWait);
    if not FindResult(Response, '2') then
        RaiseException('Modem not capable of Class 2 fax operation');
end;

{ Dial phone number and wait for answer response.
  If not connected raise exception stating modem response code. }

procedure TFax.DialNumber;
var
    Response: String;
begin
    if FDialType = dtPulse then
        SendCommand(DialPulseCmd + FPhoneNo)
    else
        SendCommand(DialToneCmd + FPhoneNo);
    Response := ReceiveResponse(DialTimeoutSeconds, 1000);
    If Pos(AnswerRsp, Response) = 0 then
        RaiseException('Unable to connect. Response: ' + Response);
end;

{ Wait for the specified response string from the modem.
  Ignores any responses not conatining the specified string and raises an
  exception if the operation times out. }

function TFax.WaitForResponse(s: String): String;
begin
    try
        repeat
            Result := ReceiveResponse(CommandResponseTries, CommandResponseWait);
        until (Length(Result) = 0) or (Pos(s, Result) <> 0);
    except
        RaiseException('Error waiting for ' + s + ' response');
    end;
end;

procedure TFax.GetRemoteStationID;
var
    Response: String;
begin
    Response := WaitForResponse(StationIdRsp);
    FRemoteStationID := Copy(Response,
        Pos(StationIdRsp, Response) + Length(StationIdRsp), 255);
end;

{ Returns the 'n'th occurrence in the comma seperates list 's'.
  Only returns valid cardinal number characters. }

function TFax.ParseNumeric(s: String; n: Integer): String;
var
    CurN, i: Integer;
begin
    Result := '';
    CurN := 1;
    i := 1;
    while (CurN < n) and (i < Length(s)) do
    begin
        if s[i] = ',' then CurN := CurN + 1;
        i := i + 1;
    end;
    if CurN = n then while (s[i] <> ',') and (i < Length(s)) do
    begin
        if s[i] in ['0'..'9'] then Result := Result + s[i];
        i := i + 1;
    end;
end;

procedure TFax.GetNegotiationParameters;
var
    Response: String;
begin
    Response := WaitForResponse(NegotiationSessionRsp);
    FNegotiationParameters := Copy(Response,
        Pos(NegotiationSessionRsp, Response) + Length(NegotiationSessionRsp),
        255);
end;

{ Following stores the current session parameters as reported by +FDCS:.
  Once the fax mode, connection rate and minumun scan times per line are known
  we can calculate the minimum number of characters to send per line. }

procedure TFax.GetCurSessionParameters;
var
    Response: String;
    ModemBitRate, ModemScanTime: Integer;
begin
    Response := WaitForResponse(CurrentSessionRsp);
    FCurSessionParameters := Copy(Response,
        Pos(CurrentSessionRsp, Response) + Length(CurrentSessionRsp), 255);
    if StrToIntDef(ParseNumeric(Response, 1), 1) = 0 then
        FFaxMode := fmNormal
    else
        FFaxMode := fmFine;
    ModemBitRate := StrToIntDef(ParseNumeric(Response, 2), 5);
    if ModemBitRate > 5 then ModemBitRate := 5;
    ModemScanTime := StrToIntDef(ParseNumeric(Response, 8), 7);
    MinTransmitSize := Round(
        (MinScanSpeeds[Ord(FFaxMode), ModemScanTime] / 1000.0)
        / (1.0 / (ModemRates[ModemBitRate] / 10.0)));
end;

{ Following function is a callback used when checking if Delphi running
  in the shareware version. }

function GetWindows(Handle: HWND; Info: Pointer): BOOL; stdcall;
const
    TargetWindowName = 'Delphi 3';
var
    Dest: array[0..80] of char;
begin
    GetWindowText(Handle, Dest, sizeof(Dest) - 1);
    if StrLComp(Dest, TargetWindowName, SizeOf(TargetWindowName)) = 0 then
    begin
        TargetWindow := Handle;
        Result := False;
    end else Result := True;
end;

{ Check if Delphi running for shareware version. }

procedure TFax.CheckDelphiRunning;
begin
    TargetWindow := 0;
    EnumWindows(@GetWindows, 0);
    if TargetWindow = 0 then
        RaiseException('Unregistered version of TFax. Delphi 3 must be running.');
end;

{ Setup modem, dial number and wait for connection. }

procedure TFax.InitiateConnection;
begin