この発言は
#00986　ＫｅＹ          さんのTServerSocketでブロッキング通信
に対するコメントです



  
 

みなさんこんにちは、ＫｅＹです。

TServerSocketでstThreadBlockingを使用するときのサンプルです。
WindowsNTで動かなかったのを修正しました。
WinSock.ShutDownを明示的に行ってみたらうまくいきました。

あと、リクエストの読みとり方があんまりだったので修正しました。

アップロード前にホームページのテストをしてみたりするのにどうぞ。

//----Unit1.pasここから
unit Unit1;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls,
  Forms, Dialogs, StdCtrls, ScktComp, WinSock;

type
  TForm1 = class(TForm)
    ServerSocket1: TServerSocket;
    procedure ServerSocket1GetThread(Sender: TObject;
      ClientSocket: TServerClientWinSocket;
      var SocketThread: TServerClientThread);
    procedure FormCreate(Sender: TObject);
    procedure FormDestroy(Sender: TObject);
  private
    { Private 宣言 }
  public
    { Public 宣言 }
  end;

  TTinyHttpdThread = class(TServerClientThread)
  private
    { Private 宣言 }
  protected
    procedure ClientExecute; override;
  end;

const
  RootDir='c:\Delphi4\Httpd\Root';  //ドキュメントルート
  PortNo=8080;                      //ポート番号
  DefaultDoc='index.html';          //デフォルトの文書名

  Response403='HTTP/1.0 403 Forbidden'#13#10+
    'Content-Type: text/plain'#13#10#13#10'Error 403 Forbidden';
  Response404='HTTP/1.0 404 Not Found'#13#10+
    'Content-Type: text/plain'#13#10#13#10'Error 404 Not Found';

var
  Form1: TForm1;

implementation

{$R *.DFM}

var
  ContentTypes: TStrings;

procedure TForm1.FormCreate(Sender: TObject);
begin
  ServerSocket1.Port:=PortNo;
  ServerSocket1.ServerType:=stThreadBlocking;
  ServerSocket1.Active:=True;
end;

procedure TForm1.FormDestroy(Sender: TObject);
begin
  if ServerSocket1.Active then
  begin
    ServerSocket1.Active:=False;
  end;
end;

procedure TForm1.ServerSocket1GetThread(Sender: TObject;
  ClientSocket: TServerClientWinSocket;
  var SocketThread: TServerClientThread);
begin
  SocketThread:=TTinyHttpdThread.Create(False, ClientSocket);
end;

{ TTiniHttpdThread }

procedure TTinyHttpdThread.ClientExecute;
var
  Stream: TWinSocketStream;
  Buffer: array[0..4095] of Char;
  GetSize: Integer;

  HttpReqStr: TStrings;
  HttpReqHeaderFlg: Boolean;  //まだHTTPヘッダの中かどうかのフラグ

  s: string;
  i: Integer;

  SendFile: TFileStream;
  SendFileExt: string;
  SendHeader: string;
  ContentType: string;
begin
  HttpReqStr:=TStringList.Create;
  try
    //このループはお決まりのもの ただしこのプログラムでは機能しない
    while (not Terminated) and ClientSocket.Connected do
    begin
      try
        //ソケットストリームの作成
        Stream:=TWinSocketStream.Create(ClientSocket, 60000);
        try
          //受信可能状態になるのを待つ
          if Stream.WaitForData(60000) then
          begin
            //リクエストを読んでTStringsに保存
            HttpReqHeaderFlg:=True;
            HttpReqStr.Clear;
            HttpReqStr.Add('');
            GetSize:=Stream.Read(Buffer, sizeof(Buffer));
            if GetSize=0 then
              Exit;

            while HttpReqHeaderFlg do
            begin
              for i:=0 to GetSize-1 do
              begin
                case Buffer[i] of
                #13:
                    if HttpReqStr.Strings[HttpReqStr.Count-1]='' then
                    begin
                      //空行だったらヘッダ部の終わり
                      //  本当なら、POSTメソッドの場合にはその引数が
                      //  この後に続く。この例ではGETメソッドしか見て
                      //  ないのでここで終わり
                      HttpReqHeaderFlg:=False;
                      break; //for i:=0〜
                    end
                    else
                      HttpReqStr.Add('');
                #10: ;    //ここは手抜き。#13#10がセットで現れる
                          //ことを期待して、#10を無視している
                else
                  HttpReqStr.Strings[HttpReqStr.Count-1]:=
                    HttpReqStr.Strings[HttpReqStr.Count-1]+Buffer[i];
                end;
              end;

              if HttpReqHeaderFlg then
              begin
                GetSize:=Stream.Read(Buffer, sizeof(Buffer));

                if GetSize=0 then
                  Exit;
              end;
            end;

            //GETメソッドか？
            if CompareText(
                Copy(HttpReqStr.Strings[0], 1, 4),'GET ')=0 then
            begin
              //'GET 'を削除
              s:=Copy(HttpReqStr.Strings[0], 5,
                  Length(HttpReqStr.Strings[0]));
              s:=Trim(s);

              //ディレクトリ部分だけ抜き出す
              if Pos(' ', s)>0 then
                s:=Copy(s, 1, Pos(' ', s)-1);

              //'/'を'\'に変更
              s:=StringReplace(s, '/', '\', [rfReplaceAll]);

              //ルートディレクトリを付ける
              s:=rootdir+s;

              //最後がフォルダならデフォルトファイルを追加
              if s[Length(s)]='\' then
                s:=s+DefaultDoc;

              //ファイルをオープン
              //    CGI引数付きのGETメソッドはここで失敗する
              //    また引数なしのCGIプログラムはそのまま
              //    ファイルを渡してしまうので注意
              try
                SendFile:=TFileStream.Create(
                  s, fmOpenRead or fmShareDenyWrite
                );
              except
                //失敗したら404のエラー
                SendFile:=nil;
                s:=Response404;
                Stream.Write(s[1], Length(s));
              end;

              if Assigned(SendFile) then
              begin
                try
                  //拡張子を取得
                  SendFileExt:=ExtractFileExt(s);

                  //'.'を取り除く
                  Delete(SendFileExt,1,1);

                  //Content-Typeを決定
                  ContentType:=ContentTypes.Values[s];
                  if s='' then
                    ContentType:='application/octet-stream';

                  //最低限のヘッダを送信
                  SendHeader:='HTTP/1.0 200 '#13#10+
                      'Content-Type: '+ContentType+#13#10#13#10;
                  Stream.Write(SendHeader[1], Length(SendHeader));

                  //ファイルを送信
                  GetSize:=SendFile.Read(Buffer, sizeof(Buffer));
                  while GetSize>0 do
                  begin
                    Stream.Write(Buffer, GetSize);

                    GetSize:=SendFile.Read(Buffer, sizeof(Buffer));
                  end;
                finally
                  SendFile.Free;
                end;
              end;
            end
            else begin
              //GETメソッド以外には対応していない
              s:=Response403;
              Stream.Write(s[1], Length(s));
            end;
          end;
        finally
          //ソケットストリームを破棄
          Stream.Free;

          //ClientSocket.Closeの中でshutdownしていないためか
          //このプログラムをNTで動かすとブラウザがエラーを出す
          //明示的にshutdownしておくと回避できるようだ
          WinSock.shutdown(ClientSocket.SocketHandle, 2);
        end;
        Exit;
      except
        HandleException;
      end;
    end;
  finally
    HttpReqStr.Free;
  end;
end;

initialization
  ContentTypes:=TStringList.Create;
  ContentTypes.Add('HTML=text/html');
  ContentTypes.Add('HTM=text/html');
  ContentTypes.Add('JPEG=image/jpeg');
  ContentTypes.Add('JPG=image/jpeg');
  ContentTypes.Add('GIF=image/gif');
finalization
  ContentTypes.Free;
end.
//----Unit1.pasここまで


                              99/12/8(Wed) 09:21pm  VEJ04660 ＫｅＹ

Original document by ＫｅＹ          氏 ID:(VEJ04660)

ここにあるドキュメントは NIFTY SERVEの Delphi Users' Forum の16番会議室「玉石混淆みんなで作るSample蔵」に投稿されたサンプルです。これらのサンプルはボーランド株式会社がサポートする公式のものではありません。また、必ずしも動作が検証されているものではありません。これらのサンプルを使用したことに起因するいかなる損害も投稿者、およびフォーラムスタッフはその責めを負いません。使用者のリスクの範疇でご使用下さい。