package H_HTTP2; use Config; use Digest::MD5; use Fcntl q(:flock); use File::Basename; use File::stat; use IO::File; use IO::Socket; use MIME::Base64 (); use Time::gmtime; use Time::Local; use strict; use vars q($VERSION); use constant CRLF => "\x0D\x0A"; use constant SP => "\x20"; use constant DEFAULT_PORT => 80; use constant HTTP_VERSION => "HTTP/1.1"; q$Id: H_HTTP2.pm,v 2.5.1 2005/07/01 08:00:00 H-Hash Exp $ =~ /,v ([\w.-]+) /, $VERSION = $1; ############################################################ # 初期設定 sub _init_ ($) { ############################## my $self = shift; # ユーザエージェント $self->agent( "H_HTTP.pm/$VERSION (StudyingHTTP.NET)" ); # Accept-* ヘッダ $self->accept({ -char => ["EUC-JP", "ISO-2022-JP", "Shift_JIS", "*"], -lang => ["ja", "en-US", "en"], }); # リクエストヘッダ $self->header({ 'TE' => "trailers", }); # リクエストのタイムアウト値 $self->timeout(10); # リダイレクションの最大回数 $self->redirection_times(1); # HTTP クッキー用ファイル $self->cookies_file('cookies.txt'); } #********************************************************************* =head1 NAME H_HTTP2 - Perl で HTTP/1.1 クライアントを書くためのモジュール =head1 SYNOPSIS use H_HTTP2; $HTTP = H_HTTP2->new; # リクエストする URL をセット $HTTP->url('http://www.studyinghttp.net/~A/Z?@_@#top'); $HTTP->url('path') # /~A/Z $HTTP->url('full_path') # /%7eA/Z?%40_%40 # リクエストヘッダを指定 $HTTP->agent('TinyAgent '. $HTTP->agent); $HTTP->refer('http://www.studyinghttp.net/'); $HTTP->ims('Fri, 01 Aug 2003 10:20:30 GMT'); $HTTP->auth('guest', 'guest'); $HTTP->set_cookie({ name => 'HOGE', # 必須 value => 'HUGA', # 必須 domain => 'www.studyinghttp.net', expires => 'Thu, 01-Apr-2004 12:00:00 GMT', max_age => 123, path => '/~foobar', }); # GET リクエストの結果を標準出力へ $HTTP->method('GET'); $HTTP->transaction; print $HTTP->content; # よく使うメソッドはショートカットを提供 $HTTP->get; $HTTP->print; # POST リクエストで、ファイルのアップロード @list = ('C:\My Documents\HTTP.png', 'image/png'); %hash = (message=>"Hello", name=>"H-Hash", upload=>\@list); $HTTP->multipart_formdata(\%hash); $HTTP->method('POST'); $HTTP->transaction; print $HTTP->response_body; # 部分的 GET (レジューム) リクエスト $HTTP->resume("file.txt"); # HTTP でよく使うエンコードやダイジェストを実装 $HTTP->percent_encoding('あいうえお'); $HTTP->encode_base64('あいうえお'); $HTTP->md5('あいうえお'); # リソースの MIME が text/html ならば… if ($HTTP->content('type') eq 'text/html') { ... } # リクエスト先のリソースが既に無ければ… if ($HTTP->is_not_found) { ... } =head1 DESCRIPTION Perl のオブジェクト指向スタイルで HTTP クライアントを書くためのメソッ ドを提供します。 =head1 CONSTRUCTOR =item new 新しいオブジェクトを作成します。 $HTTP = H_HTTP2->new; =head1 METHODS H_HTTP.pm が提供する主なメソッドです。 =head2 URL =item url([$param]) URL を扱うためのメソッドです。$param に http_URL を指定すると、それを オブジェクトに組み込みます。また、引数に以下の文字列を指定すると、セッ トされた URL から、その一部を取り出します。 $HTTP->url('http://www.studyinghttp.net/~A/Z?@_@#top'); $HTTP->url('scheme') # http $HTTP->url('netloc') # www.studyinghttp.net:80 $HTTP->url('host') # www.studyinghttp.net $HTTP->url('port') # 80 $HTTP->url('path') # /~A/Z $HTTP->url('epath') # /%7eA/Z $HTTP->url('query') # @_@ $HTTP->url('equery') # %40_%40 $HTTP->url('frag') # top $HTTP->url('full_dir') # /%7eA/ $HTTP->url('full_path') # /%7eA/Z?%40_%40 $HTTP->url('base_href') # http://www.studyinghttp.net/%7eA/ $HTTP->url('full_url') # http://www.studyinghttp.net/%7eA/Z?%40_%40 $HTTP->url() # http://www.studyinghttp.net/~A/Z?@_@#top 引数を省略した場合は、現在セットされている URL を返します。 =item grab_urls($str[, $uniq]) $str 中の http_URL らしき文字列を判別します。リストコンテキストでは http_URL らしき文字列を全て返します。スカラコンテキストでは http_URL らしき文字列の数を返します。第二引数を真とした場合は、重複する http_URL を除きます。 =item cmp_urls($url1[, $url2]) $url1 と $url2 が等価の場合に 1 を返します。$url2 を省略した場合、 url() にセットされている URL と比較します。 $url1 = 'http://www.studyinghttp.net/~abc/def'; $url2 = 'HTTP://www.StudyingHTTP.NET:80/%7Eabc/def#ghi'; $HTTP->cmp_urls($url1, $url2); # 1 =item percent_encoding($str[, $regexp]) 文字列をパーセントエンコーディングしたものを返します。第二引数を省略し た場合は通常のエスケープをしますが、正規表現を与える事であらゆるエスケ ープができます。 =item url_escape($str[, $regexp]) percent_encoding() と同等の機能を持ちます。このメソッドは、v 2.3 以前 との後方互換のためだけに存在します。 =item percent_decoding($str) 文字列をパーセントデコーディングしたものを返します。 =item url_unescape($str) percent_decoding() と同等の機能を持ちます。このメソッドは、v 2.3 以前 との後方互換のためだけに存在します。 =item relative_to_absolute($path) 相対パスを絶対パスにしたものを返します。基準 URL は url() にセットされ た URL となります。 =head2 HTTP Transaction =item transaction() ソケットを作成してリクエストを試行します。レスポンスが得られれば真を返 します。 =item method([$method]) リクエストメソッドをセットします。引数を省略した場合は、現在セットされ ているメソッドを返します。初期値は GET です。 =item request_url([$url]) HTTP リクエストを送る URL を返します。request_url() をセットせずに transaction() を実行すると、url() でセットした URL を元にリクエストを 試行します。 =item request_header() HTTP リクエスト時に送るヘッダを返します。 =item query_string([$query]) リクエストメッセージにクエリストリングをセットします。引数を省略した場 合は、現在セットされているクエリを返します。 # ハッシュ形式 (推奨) $HTTP->query_string({ query => "ABC", param => "123", }); # 本来送られる形式 $HTTP->query_string('query=ABC¶m=123'); =item multipart_formdata([\%querydata]) リクエストメッセージにマルチパートデータをセットします。エンティティ中 にファイルを含む場合は、ファイルへのパスとそのファイルの MIME から成る リストのリファレンスを指定して下さい。MIME を省略すると "application/octet-stream" となります。引数を省略した場合は、現在セッ トされているクエリを返します。 # ファイルへのパスとファイルの MIME を一まとめにしたリスト @list = ('C:\My Documents\HTTP.png', 'image/png'); # リストのリファレンスで指定 %hash = (message=>"Hello", name=>"H-Hash", upload=>\@list); $HTTP->multipart_formdata(\%hash); =item request_message([$message]) リクエストメッセージに $message をセットします。引数を省略した場合は、 現在セットされているメッセージを返します。 =head2 REQUEST_SHORTCUT =item get() GET リクエストをします。リクエストが成功したらサーバから返された HTTP ステータスコードを、失敗したら偽の値を返します。 =item head() HEAD リクエストをします。リクエストが成功したらサーバから返された HTTP ステータスコードを、失敗したら偽の値を返します。 =item post($entity[, "multipart"]) POST リクエストをします。レスポンスボディを返します。エンティティは、 以下の 2 通りで指定できます。 # ハッシュ形式 (推奨) $HTTP->post({ query => "ABC", param => "123", }); # 本来送られる形式 $HTTP->post('query=ABC¶m=123'); "multipart/form-data" を利用する場合、第2引数を "multipart" とします。 その際、エンティティ中にファイルを含む場合は、ファイルへのパスとそのフ ァイルの MIME から成るリストのリファレンスを指定して下さい。MIME を省 略すると "application/octet-stream" となります。 # ファイルへのパスとファイルの MIME を一まとめにしたリスト @list = ('C:\My Documents\HTTP.png', 'image/png'); # リストのリファレンスで指定 %hash = (message=>"Hello", upload=>\@list); $HTTP->post(\%hash, 'multipart'); リクエストが成功したらサーバから返された HTTP ステータスコードを、失敗 したら偽の値を返します。 =item options(['*']) OPTIONS リクエストをします。通常は url() でセットされた URL に対してリ クエストを行いますが、引数を '*' にした場合は、そのドメイン上のサーバ へリクエストを行います。 $HTTP->options('*'); リクエストが成功したらサーバから返された HTTP ステータスコードを、失敗 したら偽の値を返します。 =item trace($max_forwards) TRACE リクエストをします。引数では Max-Forwards ヘッダの値を指定できま す。 $HTTP->trace(10); リクエストが成功したらサーバから返された HTTP ステータスコードを、失敗 したら偽の値を返します。 =item getstore($file) GET リクエストを行い、200 レスポンス時のみエンティティボディをファイル に入力します。リクエストが成功したらサーバから返された HTTP ステータス コードを、失敗したら偽の値を返します。 # ファイル名 data.txt にボディを保存 $HTTP->getstore('data.txt'); =item resume($file) ファイルのレジューム (ダウンロードの再開) のための GET リクエストを試 み、200 及び 206 レスポンス時のみエンティティボディをファイルに追加入 力します。リクエストが成功したらサーバから返された HTTP ステータスコー ドを、失敗したら偽の値を返します。 # ファイル名 data.txt をレジューム $HTTP->resume('data.txt'); =head2 RESPONSE =item response_header レスポンスヘッダ全体を返します。 =item response_body レスポンスボディを返します。 =item content([$param]) レスポンスの内容について、いくつかのプロパティを持っています。 $HTTP->content('body') # エンティティボディ $HTTP->content('length') # エンティティの大きさ $HTTP->content('type') # エンティティの MIME タイプ $HTTP->content('encode') # エンティティのエンコード $HTTP->content('md5') # エンティティの MD5 $HTTP->content('range') # エンティティボディの範囲 $HTTP->content('lang') # エンティティボディの自然言語 $HTTP->content('charset') # エンティティボディの文字セット 引数にプロパティ名を指定して呼び出すと、そのプロパティの値を返します。 引数無しで呼び出した場合は、エンティティボディを返します。 =item print([$fh]) エンティティボディを $fh に出力します。引数を省略した場合は標準出力に 出力します。 # ファイルハンドル に出力 $HTTP->print('IN'); =item store($file) エンティティボディをファイルに保存します。成功すると、サーバから返され た HTTP ステータスコードを返します。 # ファイル名 data.txt に保存 $HTTP->store('data.txt'); =head2 Status Code =item status_code ステータスコードを返します。 =item is_successful ステータスコードが 2xx の時、真を返します。 =item is_ok ステータスコードが 200 の時、真を返します。 =item is_created ステータスコードが 201 の時、真を返します。 =item is_accepted ステータスコードが 202 の時、真を返します。 =item is_non_authoritative_information ステータスコードが 203 の時、真を返します。 =item is_no_content ステータスコードが 204 の時、真を返します。 =item is_reset_content ステータスコードが 205 の時、真を返します。 =item is_partial_content ステータスコードが 206 の時、真を返します。 =item is_multi_status ステータスコードが 207 の時、真を返します。 =item is_im_used ステータスコードが 226 の時、真を返します。 =item is_redirection ステータスコードが 3xx の時、真を返します。 =item is_multiple_choices ステータスコードが 300 の時、真を返します。 =item is_moved_permanently ステータスコードが 301 の時、真を返します。 =item is_found ステータスコードが 302 の時、真を返します。 =item is_see_other ステータスコードが 303 の時、真を返します。 =item is_not_modified ステータスコードが 304 の時、真を返します。 =item is_use_proxy ステータスコードが 305 の時、真を返します。 =item is_temporary_redirect ステータスコードが 307 の時、真を返します。 =item is_client_error ステータスコードが 4xx の時、真を返します。 =item is_bad_request ステータスコードが 400 の時、真を返します。 =item is_unauthorized ステータスコードが 401 の時、真を返します。 =item is_payment_required ステータスコードが 402 の時、真を返します。 =item is_forbidden ステータスコードが 403 の時、真を返します。 =item is_not_found ステータスコードが 404 の時、真を返します。 =item is_method_not_allowed ステータスコードが 405 の時、真を返します。 =item is_not_acceptable ステータスコードが 406 の時、真を返します。 =item is_proxy_authentication_required ステータスコードが 407 の時、真を返します。 =item is_request_timeout ステータスコードが 408 の時、真を返します。 =item is_conflict ステータスコードが 409 の時、真を返します。 =item is_gone ステータスコードが 410 の時、真を返します。 =item is_length_required ステータスコードが 411 の時、真を返します。 =item is_precondition_failed ステータスコードが 412 の時、真を返します。 =item is_request_entity_too_large ステータスコードが 413 の時、真を返します。 =item is_request_uri_too_long ステータスコードが 414 の時、真を返します。 =item is_unsupported_media_type ステータスコードが 415 の時、真を返します。 =item is_requested_range_not_satisfiable ステータスコードが 416 の時、真を返します。 =item is_expectation_failed ステータスコードが 417 の時、真を返します。 =item is_unprocessable_entity ステータスコードが 422 の時、真を返します。 =item is_locked ステータスコードが 423 の時、真を返します。 =item is_failed_dependency ステータスコードが 424 の時、真を返します。 =item is_upgrade_required ステータスコードが 426 の時、真を返します。 =item is_server_error ステータスコードが 5xx の時、真を返します。 =item is_internal_server_error ステータスコードが 500 の時、真を返します。 =item is_not_implemented ステータスコードが 501 の時、真を返します。 =item is_bad_gateway ステータスコードが 502 の時、真を返します。 =item is_service_unavailable ステータスコードが 503 の時、真を返します。 =item is_gateway_timeout ステータスコードが 504 の時、真を返します。 =item is_http_version_not_supported ステータスコードが 505 の時、真を返します。 =item is_variant_also_negotiates ステータスコードが 506 の時、真を返します。 =item is_insufficient_storage ステータスコードが 507 の時、真を返します。 =item is_not_extended ステータスコードが 510 の時、真を返します。 =item is_error is_client_error か is_server_error が真の時、真を返します。 =head2 HTTP HEADERS =item header($field[=> $val, ...]) 引数に HTTP ヘッダ名のみを指定して呼び出すと、そのヘッダに設定されてい る値を返します。 # "Content-Type" というヘッダの値を取り出す $HTTP->header('Content-Type'); 引数に ('ヘッダ名' => '値') というハッシュ、またはそのリファレンスを指 定すると、そのヘッダの値を設定 (既に値が入っていれば書き換え) を行いま す。 # "X-Hoge: Huga" というヘッダをセットする $HTTP->header('X-Hoge' => 'Huga'); =item host([$host]) 現在 Host ヘッダに設定されている値を返します。値の設定/書換を行う場合 は、ホスト名 (必要があればポート番号も) で指定して下さい。 # Host ヘッダを書き換える $HTTP->host('www.studyinghttp.net:80'); =item agent([$user_agent]) 現在 User-Agent ヘッダに設定されている値を返します。値の設定/書換を行 う場合は、HTTP/1.1 で利用可能な User-Agent の形式で指定して下さい。 # User-Agent ヘッダを書き換える $HTTP->agent('TinyAgent'); =item from([$mail_addr]) 現在 From ヘッダに設定されている値を返します。値の設定/書換を行う場合 は、メールアドレスを含めて下さい。 # From ヘッダを書き換える $HTTP->from('null@studyinghttp.net'); =item refer([$url]) 現在 Referer ヘッダに設定されている値を返します。値の設定/書換を行う場 合は、URL を含めて下さい。相対 URL の場合は絶対 URL に変換されます。 # Referer ヘッダを書き換える $HTTP->refer('http://www.studyinghttp.net/'); =item cache([$cache_directive]) キャッシュ関連のヘッダの値を設定します。引数を 'no-cache' とすると、レ スポンスにキャッシュを使用しないように指示するヘッダを設定します。また 引数を数字にすると、有効期限がその秒数以内のものを送信するように指示し ます。また、引数無しで呼び出すと、現在 Cache-Control ヘッダに設定され ている値を返します。 # レスポンスにキャッシュを使用しない $HTTP->cache('no-cache'); # レスポンスの有効期限が1時間以内 $HTTP->cache(3600); =item ims([$date]) 現在 If-Modified-Since ヘッダに設定されている値を返します。値の設定/書 換を行う場合は、HTTP/1.1 で認められている日付形式かエポック秒で指定し て下さい。現在セットしているものを取り消す場合、引数に 'X' を指定しま す。 # If-Modified-Since ヘッダを書き換える $HTTP->ims(1100000000); # If-Modified-Since ヘッダを取り消す $HTTP->ims('X'); =item range($range) 現在 Range ヘッダに設定されている値を返します。値の設定/書換を行う場合 は、以下を参考にして下さい。現在セットしているものを取り消す場合、引数 に 'X' を指定します。 # 先頭 1Kb のみを取得 $HTTP->range('0-1024'); # 末尾 1Kb のみを取得 $HTTP->range('-1024'); # 500バイト目から1000バイト目までを取得 $HTTP->range('500-1000'); # リソース全体を取得 $HTTP->range('X'); =item auth($id, $pass) 現在 Authorization ヘッダにて送られる設定の $id と $pass を返します。 現在は、Basic 認証と Digest 認証に対応しています。 =item location() 現在 Location ヘッダに設定されている値を返します。もし、相対 URL が送 られていたとしても、自動的に絶対 URL に変換したものを返します。 =item set_cookie($cookie) HTTP クッキーを設定します。クッキーは、以下の 2 通りで指定できます。 # ハッシュ形式 (推奨) $HTTP->set_cookie({ name => 'HOGE', # 必須 value => 'HUGA', # 必須 domain => 'www.studyinghttp.net', expires => 'Thu, 01-Apr-2004 12:00:00 GMT', max_age => 123, path => '/~foobar', # secure => 1, }); # 本来送られる形式 $HTTP->set_cookie('HOGE=HUGA;domain=www.studyinghttp.net;...'); max_age 属性は、expires 属性より優先されます。secure 属性がある場合、 そのクッキーは破棄されます。 =item accept($hash_ref) Accept-* ヘッダに値をセットします。ハッシュのキーには "-" 以降の文字列 を指定します。その値には、ヘッダの値を並べたリストのリファレンスを指定 します。品質値はリストの上位から自動的に決定します。 # Accept-* ヘッダを書き換える $self->accept({ Charset => ["EUC-JP", "ISO-2022-JP", "Shift_JIS", "*"], Language => ["ja", "en-US", "en"], }); なお、キーに -type と指定すると Accept ヘッダ -char と指定すると Accept-Charset ヘッダ -lang と指定すると Accept-Language ヘッダ と解釈します。 =head2 DATE/TIME FORMATS =item epoch_to_rfc1123date([$time]) エポック秒から RFC1123 形式の日付フォーマットを生成します。時刻は秒数 で指定しますが、引数を省略すると現在の時刻を指定した事になります。引数 を理解できない場合は、未定義値を返します。 # Tue, 09 Nov 2004 11:33:20 GMT $HTTP->epoch_to_rfc1123date(1100000000); =item date_to_epoch($date) HTTP 日付フォーマットからエポック秒を生成します。使用可能なフォーマッ トは RFC1123 形式、RFC850 形式、ANSI C の asctime() 形式、Netscape- Cookies 形式です。引数を理解できない場合は、未定義値を返します。 # RFC1123 形式 $HTTP->date_to_epoch('Sun, 09 Sep 2001 01:46:40 GMT'); # RFC850 形式 $HTTP->date_to_epoch('Sunday, 09-Sep-01 01:46:40 GMT'); # asctime() 形式 $HTTP->date_to_epoch('Sun Sep 9 01:46:40 2001'); # Netscape-Cookies 形式 $HTTP->date_to_epoch('Sun, 09-Sep-2001 01:46:40 GMT'); =head2 OTHERS =item md5($data) MD5 アルゴリズムにより、$data のメッセージダイジェストを返します。 =item encode_base64($param) Base64 エンコーディングを行います。但し、76文字/行の折り返し機能はあり りませんのでご注意下さい。 =item decode_base64($param) Base64 デコーディングを行います。 =item timeout([$secs]) リクエストのタイムアウト値を設定します。引数無しで呼び出すと、現在タイ ムアウト値に設定されている値を返します。 # タイムアウト値を 10 秒にする $HTTP->timeout('10'); =item redirection_times([$times]) HEAD/GET リクエスト時に、レスポンスのステータスコードが 301 か 302 で あった場合、自動でリダイレクトする最大回数を指定します。引数無しで呼び 出すと、現在設定されている値を返します。 # リダイレクトしないようにする $HTTP->redirection_times('0'); 指定する際は、あまり大きな数にすると無限ループの要因になるかもしれない ので注意しましょう。RFC2068 では、最大 5 回が推奨されています。 =item cookies_file([$cookies_file]) HTTP クッキー用ファイルを設定します。引数無しで呼び出すと、現在クッキ ー用ファイル値に設定されている値を返します。クッキーを使用しない場合 は、引数に 'X' を指定します。 # クッキーを使用しない $HTTP->cookies_file('X'); =item proxy([$host_port]) 通信に使用するプロクシを設定します。引数無しで呼び出すと、現在設定され ている値を返します。プロクシを使用しない場合は、引数に 'X' を指定しま す。 # プロクシをセット $HTTP->proxy('proxy.host.com:8080'); # プロクシを使用しない $HTTP->proxy('X'); =head1 SEE ALSO RFC 2616 (Hypertext Transfer Protocol -- HTTP/1.1) RFC 2617 (HTTP Authentication) =head1 REFERENCES http://www.studyinghttp.net/H_HTTP2#References =head1 HISTORY http://www.studyinghttp.net/H_HTTP2#History =head1 AUTHOR Copyright (C) 1999-2005; H-Hash 連絡は http://www.studyinghttp.net/help#Mail まで。 =cut #********************************************************************* # Constructor ############################################################ sub new ($) { ############################## my $self = bless { _request => { method => 'GET' }, _response => { auth => undef }, }, shift; $self->_init_; $self; } #********************************************************************* # URL ############################################################ # URL を扱う sub url ($;$) { ############################## my $self = shift; my $str = shift || 'as_string'; # set url if ($str =~ m|^http://+|i) { $self->{_url} = _parse_url($str) || return; $str = 'as_string'; } $self->{_url}->{$str}; } ############################################################ # 文字列に http_URL が含まれているかどうかを判別 sub grab_urls ($$;$) { ############################## my $self = shift; my $str = shift; my $uniq = shift; my(@ret, %count); my $url_regexp = q{http://}. _regexp('host') .q{(?::}. _regexp('port') .q{?)?}. _regexp('abs_path') .q{?(?:\?(?:}. _regexp('query') .q{)?)?(?:#(?:}. _regexp('fragment') .q{)?)?(?![\w-.!~*'();/?:@&=+$,#])}; #' @ret = $str =~ /($url_regexp)/gio; $uniq ? grep(!$count{$_}++, @ret) : @ret; } ############################################################ # URL を比較 sub cmp_urls ($$;$) { ############################## my $self = shift; my $url1 = shift; my $url2 = shift || $self->url; $url1 = _parse_url($url1)->{full_url}; $url1 =~ s/%([0-9A-Fa-f][0-9A-Fa-f])/lc($1)/eg; $url2 = _parse_url($url2)->{full_url}; $url2 =~ s/%([0-9A-Fa-f][0-9A-Fa-f])/lc($1)/eg; $url1 eq $url2 } ############################################################ # 文字列をパーセントエンコーディング sub percent_encoding ($$;$) { ############################## my $self = shift; my $str = shift; my $ptrn = shift || q/^\w*-. /; $str =~ s/([$ptrn])/'%' . lc(unpack("H2", $1))/eg; $str =~ tr/ /+/; $str; } ############################## sub url_escape($$;$) { shift->percent_encoding(@_); } ############################################################ # 文字列をパーセントデコーディング sub percent_decoding ($$) { ############################## my $self = shift; my $str = shift; $str =~ tr/+/ /; $str =~ s/%([0-9A-Fa-f][0-9A-Fa-f])/pack("H2", $1)/eg; $str; } ############################## sub url_unescape($$;$) { shift->percent_decoding(@_); } ############################################################ # 相対パスを絶対パスにする sub relative_to_absolute ($$) { ############################## my $self = shift; my $path = shift; my($cnt, $loc); return $path if $path =~ m|^http://.+|; $path = m|^/| ? $path : $self->url('full_dir') . $path; $path .= ">" if $path =~ m|/$|; foreach (reverse split('/', $path)) { next if not $_ or $_ eq '.'; ++$cnt, next if $_ eq '..'; $cnt ? (--$cnt) : ($loc = "/$_/" . $loc); } $loc =~ s|>?/$||; $loc =~ s|/{2,}|/|g; $self->url('scheme') . "://" . $self->url('netloc') . $loc; } ############################################################ # http_URL を解析する sub _parse_url ($) { ############################## my $url_str = shift; my($full_path, $full_dir, %url); my $url_regexp = q{http://(}. _regexp('host') .q{)(?::(}. _regexp('port') .q{)?)?(}. _regexp('abs_path') .q{)?(?:\?(}. _regexp('query') .q{)?)?(?:#(}. _regexp('fragment') .q{)?)?(?![\w-.!~*'();/?:@&=+$,#])}; #' return unless $url_str =~ /^$url_regexp/i; $url{as_string} = $url_str; $url{host} = $1; $url{port} = (defined $2 ? $2 : DEFAULT_PORT); $url{path} = (defined $3 ? $3 : '/'); $url{query} = $4; $url{frag} = $5; $url{scheme} = 'http'; $url{netloc} = lc($url{host} .':'. $url{port}); $url{epath} = H_HTTP2->percent_encoding($url{path}, q[^\w*-. /&%]); $url{equery} = H_HTTP2->percent_encoding($url{query}, q[^\w*-. =&;]); $url{full_path} = $url{epath} . ($url{equery} ? '?'. $url{equery} : undef); fileparse_set_fstype('UNIX'); $url{full_dir} = $url{full_path} =~ m|/$| ? $url{full_path} : dirname($url{full_path}) .'/'; $url{full_dir} =~ s|/{2,}|/|g; $url{base_href} = $url{scheme} .'://'. $url{netloc} . $url{full_dir}; $url{full_url} = $url{scheme} .'://'. $url{netloc} . $url{full_path}; \%url; } ############################################################ # 各パラメータの正規表現 sub _regexp ($) { ############################## my $param = shift; if ($param eq 'host') { q{(?:}. # Domain name q{(?:[A-Za-z0-9](?:[-A-Za-z0-9]*[A-Za-z0-9])?\.)+[A-Za-z]{2,}\.?}. q{|}. # IPv4address (0-255) q{(?:(?:[1-9]?\d|1\d\d|2[0-4]\d|25[0-5])\.){3}(?:[1-9]?\d|1\d\d|2[0-4]\d|25[0-5])}. q{)}; } elsif ($param eq 'port') { q{(?:[1-9]\d{0,3}|[1-5]\d{4}|6[0-4]\d{3}|65[0-4]\d{2}|655[0-2]\d|6553[0-5])}; } elsif ($param eq 'abs_path') { q{(?:/}. q {(?:[\w-.!~*'():@&=+$,]|%[0-9A-Fa-f][0-9A-Fa-f])*}. q{(?:;(?:[\w-.!~*'():@&=+$,]|%[0-9A-Fa-f][0-9A-Fa-f])*)*}. q{(?:/(?:[\w-.!~*'():@&=+$,]|%[0-9A-Fa-f][0-9A-Fa-f])*}. q{(?:;(?:[\w-.!~*'():@&=+$,]|%[0-9A-Fa-f][0-9A-Fa-f])*)*)*}. q{)}; } elsif ($param eq 'query' or $param eq 'fragment') { q{(?:[\w-.!~*'();/?:@&=+$,]|%[0-9A-Fa-f][0-9A-Fa-f])*}; #' } elsif ($param eq 'token') { q{[^\x00-\x20"(),/:;<=>?@[\]{}\x7F]+}; #" } } #********************************************************************* # HTTP Transaction ############################################################ # ソケットを作成してリクエストし、レスポンスを得る sub transaction ($) { ############################## my $self = shift; my $cnt = $self->redirection_times; my $sock; # Request until getting [245]xx response or redirection_times while ($cnt >= 0) { $sock = IO::Socket::INET->new( PeerHost => $self->proxy || $self->url('netloc'), Proto => 'tcp', TimeOut => $self->timeout, ) or return; # Can't create new socket $sock->send( $self->request ); $sock->flush; $self->_recv_response(\$sock); $sock->close; $self->_check_status (\$cnt); # for Redirection } 1; } ############################################################ # リクエストを作成 sub request ($) { ############################## my $self = shift; $self->method . SP . $self->request_url . SP . HTTP_VERSION . CRLF . $self->request_header . CRLF . $self->request_message; } ############################################################ # リクエストメソッドの設定 sub method ($;$) { ############################## my $self = shift; my $value = shift; defined $value ? ($self->{_request}->{method} = uc($value)): $self->{_request}->{method}; } ############################################################ # リクエスト URL の設定 sub request_url ($;$) { ############################## my $self = shift; my $value = shift; if ($value) { $self->{_request}->{url} = $value; } else { $self->{_request}->{url} || ( $self->proxy ? $self->url('full_url') : $self->url('full_path') ); } } ############################################################ # リクエストメッセージの設定 sub request_message ($;$) { ############################## my $self = shift; my $value = shift; defined $value ? ($self->{_request}->{message} = $value) : $self->{_request}->{message}; } ############################################################ # リクエストメッセージの MIME タイプの設定 sub request_message_type ($;$) { ############################## my $self = shift; my $value = shift; defined $value ? ($self->{_request}->{message_type} = $value) : $self->{_request}->{message_type}; } ############################################################ # クエリストリングの設定 sub query_string ($$) { ############################## my $self = shift; my $query = shift; my($key, $value, %Q); if ($query) { if (ref $query eq 'HASH') { %Q = %$query; } else { foreach (split(/[&;]/, $query)) { ($key, $value) = split('=', $_, 2); $Q{$key} = $value; } } undef $query; foreach $key (keys %Q) { $query .= $self->percent_encoding( $self->percent_decoding($key) ) .'='. $self->percent_encoding( $self->percent_decoding($Q{$key}) ) .'&'; } chop $query; # chop last '&' $self->request_message($query); $self->request_message_type('application/x-www-form-urlencoded'); } $self->request_message(); } ############################################################ # マルチパートの設定 sub multipart_formdata ($\%) { ############################## my $self = shift; my $hash = shift; my $boundary = time; my $formdata; if ($hash) { foreach (keys %$hash) { my $key = $self->percent_encoding( $self->percent_decoding($_) ); my $header = qq(Content-Disposition: form-data; name="$key"); my $query; if (ref $hash->{$_} eq 'ARRAY') { my($fpass, $fname, $ftype, $fhandle); fileparse_set_fstype($Config{'osname'}); $fpass = $hash->{$_}->[0]; $fname = basename($fpass); $ftype = $hash->{$_}->[1] || q(application/octet-stream); $header .= qq(; filename="$fname") .CRLF. qq(Content-Type: $ftype); $fhandle = IO::File->new($fpass, "<"); 1 while $fhandle->read($query, 1024, length($query)); } else { $query = $self->percent_encoding($self->percent_decoding($hash->{$_})); } $formdata .= '--' . $boundary . CRLF . $header . CRLF . CRLF . $query . CRLF; } $formdata .= '--' . $boundary .'--'. CRLF; $self->request_message($formdata); $self->request_message_type('multipart/form-data, boundary=' . $boundary); } $self->request_message(); } ############################################################ # リクエストヘッダの設定・作成 sub request_header ($) { ############################## my $self = shift; my $hash = $self->_set_request_header || return; my($name, $value, $cookie, $ret); # Authorization header if ($self->auth and $self->_auth_flag) { $self->_set_request_header({'Authorization' => $self->_credentials}); } # Connection header if (not $self->header('Connection')) { $self->_set_request_header({'Connection' => 'close'}); } # Content-* header if ($self->request_message) { $self->_set_request_header({'Content-Length' => length($self->request_message)}); $self->_set_request_header({'Content-Type' => $self->request_message_type}); } # Cookie header if ($cookie = $self->_make_cookie) { $self->_set_request_header({'Cookie' => $cookie}); } # Host header if (not $self->host) { $value = $self->url('host') !~ /^[\d.]+$/ ? $self->url('netloc') : undef; $self->_set_request_header({'Host' => $value}); } # Range header if ($self->range) { $self->_set_request_header({'Range' => undef}) if $self->method ne 'GET'; } foreach $name (keys %$hash) { $value = $hash->{$name}; $value =~ tr/\x0D\x0A//d; # Capitalize $name =~ s/^te$/TE/; $name =~ s/md5/MD5/; $name =~ s/www/WWW/; $name =~ s/((?:^|-)[\w])/uc($1)/eg; $ret .= $name .': '. $value . CRLF if $name; } $self->_del_request_header; $ret; } ############################################################ # リクエストヘッダの設定 sub _set_request_header ($;\%) { ############################## my $self = shift; my $param = shift; # set Request Headers if ($param) { foreach (keys %$param) { my $key = lc($_); $self->{_request}->{header}->{$key} = $param->{$_}; } undef; } # return Request Headers else { my $h = $self->{_header}; foreach (keys %$h) { $self->{_request}->{header}->{$_} = $h->{$_} unless $self->{_request}->{header}->{$_}; } $self->{_request}->{header}; } } ############################## sub _make_cookie ($) { my $self = shift; my $my_domain = ".". $self->url('host'); my $my_path = $self->url('epath'); my($name, $value, $expires, $domain, $path, $store, $ret); my(@names, %opaque); my $fh = IO::File->new($self->cookies_file, "+<") or return; eval { flock($fh, LOCK_EX) or return }; while (1) { $name = $fh->getline; chomp $name; last unless $name; $value = $fh->getline; chomp $value; $expires = $fh->getline; chomp $expires; $domain = $fh->getline; chomp $domain; $path = $fh->getline; chomp $path; $fh->getline; # Discard Cookie if Expired $expires < time ? next : ($store .= "$name\n$value\n$expires\n$domain\n$path\n\n"); if ($my_domain =~ /$domain$/ and $my_path =~ /^$path/) { my $flag; for (@names) { $flag = 1 if $_ eq $name } next if $flag; $opaque{$path} .= $name ."=". $value .";"; push(@names, $name); } } $fh->seek(0, 0); $fh->print($store); $fh->truncate($fh->tell); # in order of more specific Path attributes for (reverse keys %opaque) { $ret .= $opaque{$_} } $ret; } ############################## sub _auth_flag ($;$) { my $self = shift; my $flag = shift; $self->{_response}->{auth} = 1 if $flag; $self->{_response}->{auth}; } ############################## sub _credentials ($) { my $self = shift; my $token = _regexp('token'); $self->header('WWW-Authenticate') =~ m|^($token) (.+)$|; my $scheme = $1; my $param = $2; if ($scheme eq 'Basic') { $self->_basic_credentials(); } elsif ($scheme eq 'Digest') { $self->_digest_credentials($param); } } ############################## sub _basic_credentials ($) { my $self = shift; my($id, $pass) = $self->auth; "Basic" . SP . $self->encode_base64("$id:$pass"); } ############################## sub _digest_credentials ($$) { my $self = shift; my $param = shift; my($name, $passwd) = $self->auth; my $digest = qq(username="$name", uri="). $self->request_url . qq(", ); my $algorithm = "MD5"; my @_a1 = ($name, "", $passwd); my($realm, $nonce, $cnonce, $qop, $nc, $_d_str); $param =~ s/[ \t]*,[ \t]*/,/g; $param = ','. $param .','; # realm if ($param =~ s/,realm="(.+?)",/,/) { $realm = $1; $digest .= qq(realm="$realm", ); $_a1[1] = $realm; } # nonce if ($param =~ s/,nonce="(.+?)",/,/) { $nonce = $1; $digest .= qq(nonce="$nonce", ); } # opaque if ($param =~ s/,(opaque=".+?"),/,/) { $digest .= $1 .", "; } # qop if ($param =~ s/,qop="(.+?)",/,/) { $qop = 'auth' if $1 =~ /auth/; $nc = "00000001"; $cnonce = time; # $cnonce="0a4f113b"; $_d_str = "$nc:$cnonce:$qop:"; $digest .= qq(qop=$qop, nc=$nc, cnonce="$cnonce", ); } # H_HTTP2.pm doesn't support an algorithm except "MD5". if ($param =~ s/,algorithm="(.+?)",/,/) { $algorithm = $1; return if $algorithm !~ /^MD5/; $digest .= qq(algorithm="$algorithm", ); $_a1[3] = $nonce; $_a1[4] = $cnonce; } # request-digest $digest .= qq(response=") . $self->md5( $self->md5( $self->_A1(@_a1) ) . ":$nonce:" . $_d_str . $self->md5( $self->_A2 ) ). qq("); "Digest" . SP . $digest; } ############################## sub _A1 ($$$$;$$) { my $self = shift; my $name = shift; my $realm = shift; my $passwd = shift; my $nonce = shift; my $cnonce = shift; $nonce ? $self->md5( $name .":". $realm .":". $passwd .":". $nonce .":". $cnonce ) : $name .":". $realm .":". $passwd; } ############################## sub _A2 ($) { my $self = shift; $self->method .":". $self->request_url; } ############################## sub _del_request_header ($) { delete shift->{_request}->{header}; } ############################################################ # レスポンスメッセージを受信・加工 sub _recv_response ($\$) { ############################## my $self = shift; my $sock = ${(shift)}; my $len; # Receive Response-Header 1 while $self->_parse_response_header($sock); # Receive Response-Body $self->_parse_response_body($sock); # Add "Content-Length", Compute Content-Length by myself if "chunked" is used $len = $self->{_response}->{length} ? $self->{_response}->{length} : $self->content('length'); $self->_set_response_header('Content-Length: ' . ($len ? $len : '0') . CRLF); } ############################################################ # レスポンスヘッダを解析 sub _parse_response_header ($$) { ############################## my $self = shift; my $sock = shift; my $status; # Delete Data of Last Response delete $self->{_response}; # Status Line $status = $sock->getline; $status =~ tr/\x0D\x0A//d; $self->_set_response_header($status); # Status Code $status =~ m|^HTTP/1\.[01] ([1-5][0-9][0-9]) .+|; $self->{_response}->{status} = $1; while (<$sock>) { tr/\x0D\x0A//d; last unless $_; # Get Content-Length value $self->{_response}->{length} = $1, next if /^Content-Length:[ \t]*(\d+)$/i; # Flag for "chunked" $self->{_response}->{chunked} = 1, next if /^Transfer[-_]Encoding:[ \t]*chunked/i; # for Folding Headers $self->_set_response_header((s/^[ \t]+// ? " " : CRLF) . $_); # Parse Set-Cookie Header $self->set_cookie($1) if /^Set[-_]Cookie:[ \t]*(.+)/i and $self->cookies_file; } $self->_set_response_header(CRLF); # If the status code is 1xx, discard the first response. $self->status_code =~ /^1/ ? 1 : 0; } ############################## sub _set_response_header ($$) { shift->{_response}->{header} .= shift } ############################################################ # レスポンスボディを解析 sub _parse_response_body ($$) { ############################## my $self = shift; my $sock = shift; my $range = substr($self->range, 6); my($body, $size); # Decoding "chunked" response-body if ($self->{_response}->{chunked}) { $sock->read($body, $size, length($body)) while (($size = _get_chunk_size($sock)) > 0); $self->_parse_response_header($sock) if $self->header('Trailer'); } # identity else { 1 while $sock->read($body, 4096, length($body)); } # Cutting response body if Server doesn't support range request if ($range and $self->is_ok and $self->method eq 'GET') { $range =~ /^(\d+)?-(\d+)?$/, my($f, $l) = ($1, $2); if (not defined $l) { # XXX- $body = substr($body, $f); } elsif (not defined $f) { # -YYY $body = substr($body, -$l); } else { # XXX-YYY $body = substr($body, $f, $l-$f+1); } } $self->{_response}->{body} = $body; } ############################## sub _get_chunk_size ($) { my $sock = shift; $sock->getline =~ /^([\dA-Fa-f]+)/ ? hex($1) : $sock->getline =~ /^([\dA-Fa-f]+)/, hex($1); } ############################################################ # ステータスコードを探査し、必要であればリクエストの再試行 sub _check_status ($\$) { ############################## my $self = shift; my $cref = shift; my $flag; # 30[127] if ($self->is_moved_permanently or $self->is_found or $self->is_temporary_redirect) { if ($self->method =~ /^(?:GET|HEAD)$/) { $flag = 1; $$cref--; $self->url($self->location); } } # 303 elsif ($self->is_see_other) { $flag = 1; $$cref--; $self->url($self->location); $self->method('GET'); } # 305 elsif ($self->is_use_proxy) { $self->proxy($self->location); $self->redirection_times(--$$cref); $self->transaction(); } # 401 (first time) elsif ($self->is_unauthorized and not $self->_auth_flag) { $flag = 1; # Request isn't retried If PASSWD is incorrect. $self->_auth_flag(1); } $$cref = -1 unless $flag; } #********************************************************************* # Request_SHORTCUT ############################################################ sub get ($) { ############################## my $self = shift; $self->method('GET'); $self->transaction; $self->status_code; } ############################################################ sub head ($) { ############################## my $self = shift; $self->method('HEAD'); $self->transaction; $self->status_code; } ############################################################ sub post ($$;$) { ############################## my $self = shift; my $data = shift; my $body = shift eq 'multipart' ? $self->multipart_formdata($data): $self->query_string($data); $self->method('POST'); $self->request_message($body); $self->transaction; $self->status_code; } ############################################################ sub options ($;$) { ############################## my $self = shift; $self->method('OPTIONS'); $self->request_url('*') if shift eq '*'; $self->transaction; $self->status_code; } ############################################################ sub trace ($$) { ############################## my $self = shift; my $fwd = shift || '0'; $self->method('TRACE'); $self->header({ 'Max-Forwards' => $fwd }); $self->transaction; $self->status_code; } ############################################################ sub getstore ($$) { ############################## my $self = shift; my $file = shift; $self->get; $self->store($file) if $self->is_ok; $self->status_code; } ############################################################ sub resume ($$) { ############################## my $self = shift; my $file = shift; my $range = -f $file ? stat($file)->size .'-' : 'X'; my $fh; $self->range($range); $self->get; if ($self->is_ok or $self->is_partial_content) { $fh = IO::File->new($file, ">>") or return; $self->print($fh); } $self->status_code; } #********************************************************************* # Response ############################################################ sub response_header ($) { shift->{_response}->{header} } sub response_body ($) { shift->{_response}->{body} } ############################################################ sub content ($;$) { ############################## my $self = shift; my $param = lc(shift) || 'body'; my $token = _regexp('token'); if ($param eq 'body') { $self->response_body; } elsif ($param eq 'length') { length($self->response_body); } elsif ($param eq 'lang') { $self->header('Content-Language'); } elsif ($param eq 'encode') { $self->header('Content-Encoding'); } elsif ($param eq 'md5') { $self->header('Content-MD5'); } elsif ($param eq 'range') { $self->header('Content-Range'); } elsif ($param eq 'type') { $self->header('Content-Type') =~ m|^($token/$token)| ? $1 : undef; } elsif ($param eq 'charset') { $self->header('Content-Type') =~ m|;[ \t]*charset=($token)| ? $1 : undef; } } ############################################################ sub print ($;$) { ############################## my $self = shift; my $fh = shift || 'STDOUT'; no strict 'refs'; binmode($fh); print ($fh $self->response_body); } ############################################################ sub store ($$) { ############################## my $self = shift; my $file = IO::File->new(shift, ">") or return; $self->print($file); $self->status_code; } #********************************************************************* # Status Code ############################################################ sub status_code ($) { shift->{_response}->{status} } sub is_successful ($) { shift->status_code =~ /^2/ } sub is_ok ($) { shift->status_code eq '200' } sub is_created ($) { shift->status_code eq '201' } sub is_accepted ($) { shift->status_code eq '202' } sub is_non_authoritative_information ($) { shift->status_code eq '203' } sub is_no_content ($) { shift->status_code eq '204' } sub is_reset_content ($) { shift->status_code eq '205' } sub is_partial_content ($) { shift->status_code eq '206' } sub is_multi_status ($) { shift->status_code eq '207' } sub is_im_used ($) { shift->status_code eq '226' } sub is_redirection ($) { shift->status_code =~ /^3/ } sub is_multiple_choices ($) { shift->status_code eq '300' } sub is_moved_permanently ($) { shift->status_code eq '301' } sub is_found ($) { shift->status_code eq '302' } sub is_see_other ($) { shift->status_code eq '303' } sub is_not_modified ($) { shift->status_code eq '304' } sub is_use_proxy ($) { shift->status_code eq '305' } sub is_temporary_redirect ($) { shift->status_code eq '307' } sub is_client_error ($) { shift->status_code =~ /^4/ } sub is_bad_request ($) { shift->status_code eq '400' } sub is_unauthorized ($) { shift->status_code eq '401' } sub is_payment_required ($) { shift->status_code eq '402' } sub is_forbidden ($) { shift->status_code eq '403' } sub is_not_found ($) { shift->status_code eq '404' } sub is_method_not_allowed ($) { shift->status_code eq '405' } sub is_not_acceptable ($) { shift->status_code eq '406' } sub is_proxy_authentication_required ($) { shift->status_code eq '407' } sub is_request_timeout ($) { shift->status_code eq '408' } sub is_conflict ($) { shift->status_code eq '409' } sub is_gone ($) { shift->status_code eq '410' } sub is_length_required ($) { shift->status_code eq '411' } sub is_precondition_failed ($) { shift->status_code eq '412' } sub is_request_entity_too_large ($) { shift->status_code eq '413' } sub is_request_uri_too_long ($) { shift->status_code eq '414' } sub is_unsupported_media_type ($) { shift->status_code eq '415' } sub is_requested_range_not_satisfiable ($) { shift->status_code eq '416' } sub is_expectation_failed ($) { shift->status_code eq '417' } sub is_unprocessable_entity ($) { shift->status_code eq '422' } sub is_locked ($) { shift->status_code eq '423' } sub is_failed_dependency ($) { shift->status_code eq '424' } sub is_upgrade_required ($) { shift->status_code eq '426' } sub is_server_error ($) { shift->status_code =~ /^5/ } sub is_internal_server_error ($) { shift->status_code eq '500' } sub is_not_implemented ($) { shift->status_code eq '501' } sub is_bad_gateway ($) { shift->status_code eq '502' } sub is_service_unavailable ($) { shift->status_code eq '503' } sub is_gateway_timeout ($) { shift->status_code eq '504' } sub is_http_version_not_supported ($) { shift->status_code eq '505' } sub is_variant_also_negotiates ($) { shift->status_code eq '506' } sub is_insufficient_storage ($) { shift->status_code eq '507' } sub is_not_extended ($) { shift->status_code eq '510' } sub is_error ($) { shift->status_code =~ /^[45]/ } #********************************************************************* # HTTP Headers ############################################################ # HTTP ヘッダを扱う sub header ($@) { ############################## my $self = shift; my $value = $_[0]; my %hash; # get header value if (scalar @_ == 1 and not ref $value) { $self->_search_header($value); } # rewrite header value elsif (@_) { %hash = ref $value eq 'HASH' ? %$value : @_; foreach (keys %hash) { $self->_rewrite_header($_ => $hash{$_}) } } } ############################################################ # 既に登録されている HTTP ヘッダの値を検索 sub _search_header ($$) { ############################## my $self = shift; my $name = shift; $name =~ tr/A-Z_/a-z-/; $self->_search_response_header($name) || $self->_search_my_header($name); } ############################## sub _search_response_header ($$) { my $self = shift; my $name = shift; my @head = split(/\n/, $self->response_header); my $token = _regexp('token'); my($key, $value, $ret); foreach (@head) { /^($token):[ \t]*(.+)$/, ($key, $value) = ($1, $2); $key =~ tr/A-Z_/a-z-/; if ($key eq $name) { $value =~ s/\s+$//; # 末尾の余白を削除 $value =~ s/[ \t]+/ /g; # LWS を SP に変換 $ret .= $ret ? qq(, $value) : $value; } } $ret; } ############################## sub _search_my_header ($$) { my $self = shift; my $name = shift; $self->{_header}->{$name}; } ############################################################ # 既に登録されている HTTP ヘッダの値の書き換え sub _rewrite_header ($$$) { ############################## my $self = shift; my $name = shift; my $value = shift; $name =~ tr/A-Z_/a-z-/; $value ? $self->{_header}->{$name} = $value: delete $self->{_header}->{$name}; } ############################################################ # Host ヘッダ sub host ($;$) { ############################## my $self = shift; my $obj = _parse_url('http://'. shift); $self->header('Host' => $obj->{netloc}) if $obj->{netloc}; $self->header('Host'); } ############################################################ # User-Agent ヘッダ sub agent ($;$) { ############################## my $self = shift; my $value = shift; my $token = _regexp('token'); my $ctext = '[^\x00-\x08\x0a-\x1F\x7F()]'; my $product = "(?:$token(?:/$token)?)"; my $_comment = "(?:\\\((?:$ctext|(?:\\\[\x00-\x7f]))+\\\))"; my $comment = "(?:\\\((?:$ctext|(?:\\\[\x00-\x7f])|$_comment)+\\\))"; my $useragent = "(?:$product|$comment)"; my $ua_regexp = "$useragent(?:[ \t]+$useragent)*"; $value =~ s/\s+$//g; $self->header('User-Agent' => $value) if $value =~ /^$ua_regexp$/; $self->header('User-Agent'); } ############################################################ # From ヘッダ sub from ($;$) { ############################## my $self = shift; my $value = shift; my $addr_spec = # local_part q{[^\x00-\x20"(),.:;<>@[\]\x7F]+(?:\.[^\x00-\x20"(),.:;<>@[\]\x7F]+)*}. # host q{\@}. _regexp('host'); $self->header('From' => $value) if $value =~ /$addr_spec/; $self->header('From'); } ############################################################ # Referer ヘッダ sub refer ($;$) { ############################## my $self = shift; my $obj = _parse_url($self->relative_to_absolute(shift)); $self->header('Referer' => $obj->{full_url}) if $obj->{full_url}; $self->header('Referer'); } ############################################################ # Cache 関連ヘッダ sub cache ($;$) { ############################## my $self = shift; my $value = shift; if ($value eq 'no-cache') { $self->header({ 'Pragma', => $value, 'Cache-Control' => $value, }); } elsif ($value =~ /^\d+$/) { $self->header({ 'Expires' => $self->epoch_to_rfc1123date(time+$value), 'Cache-Control' => 'max-age=' . $value, }); } $self->header('Cache-Control'); } ############################################################ # If-Modified-Since ヘッダ sub ims ($;$) { ############################## my $self = shift; my $value = shift; my $time; if ($value eq 'X') { $time = undef; } elsif ($value =~ /^\d+$/) { $time = $self->epoch_to_rfc1123date($value); } else { $time = $self->epoch_to_rfc1123date( $self->date_to_epoch($value) ); } $self->header('If-Modified-Since' => $time) if $time; $self->header('If-Modified-Since'); } ############################################################ # Range ヘッダ sub range ($;$$) { ############################## my $self = shift; my $prm1 = shift || 0; my $prm2 = shift || 0; my $value; if ($prm1 eq 'X') { return $self->header('Range' => undef); } elsif (not $prm1 and not $prm2) { return $self->header('Range'); } $value = 'bytes=' . ($prm1 =~ /^(?:\d+)?-(?:\d+)?$/ ? $prm1 : $prm1 .'-'. $prm2); $self->header('Range' => $value); $self->header('Range'); } ############################################################ # Authorization ヘッダ sub auth ($;$$) { ############################## my $self = shift; my $id = shift; my $pass = shift; if ($id and $pass) { $self->{_auth}->{id} = $id; $self->{_auth}->{pass} = $pass; } ($self->{_auth}->{id}, $self->{_auth}->{pass}); } ############################################################ # Location ヘッダ sub location ($) { ############################## my $self = shift; $self->relative_to_absolute( $self->header('Location') ); } ############################################################ # Set-Cookie ヘッダを解析し、クッキーファイルに保存 sub set_cookie ($$) { ############################## my $self = shift; my %cookie = $self->_parse_cookie(shift) or return; my $store = qq($cookie{name}\n$cookie{value}\n) . qq($cookie{expires}\n$cookie{domain}\n$cookie{path}\n\n); my($name, $value, $expires, $domain, $path, $cnt); # Save Cookies my $fh = IO::File->new($self->cookies_file, "+<") or return; eval { flock($fh, LOCK_EX) or return }; while(1) { # Store only 300 cookies last if ++$cnt > 300; $name = $fh->getline; chomp $name; last unless $name; $value = $fh->getline; chomp $value; $expires = $fh->getline; chomp $expires; $domain = $fh->getline; chomp $domain; $path = $fh->getline; chomp $path; $fh->getline; # Discard Cookie if expired next if $expires < time; # Update Old Cookie next if $name eq $cookie{name} and $domain =~ /$cookie{domain}$/ and $path =~ /^$cookie{path}/; $store .= qq($name\n$value\n$expires\n$domain\n$path\n\n); } $fh->seek(0, 0); $fh->print($store); $fh->truncate($fh->tell); } ############################## sub _parse_cookie ($$) { my $self = shift; my $cookie = shift; my $d_reg = '(?:[A-Za-z0-9](?:[-A-Za-z0-9]*[A-Za-z0-9]))?(?:' . '\.[A-Za-z0-9](?:[-A-Za-z0-9]*[A-Za-z0-9])?)+\.(' . '?:[A-Za-z]{2,}\.[A-Za-z]{2}|[A-Za-z]{3,})\.?'; my $p_reg = _regexp('abs_path'); my($attr, $value, %C, %D); if (ref $cookie eq 'HASH') { %C = %$cookie; } else { foreach (split(/[ \t]*;[ \t]*/, $cookie)) { ($attr, $value) = split('=', $_, 2); unless ($C{name}) { $C{name} = $attr; $C{value} = $value; } else { $C{$attr} = $value; } } } foreach (keys %C) { # H_HTTP2.pm doesn't support HTTPS. if (/^secure$/i) { return; } # Name elsif (/^(name)$/i) { $D{name} = $self->percent_encoding( $self->percent_decoding($C{$1} ), q[^\w*-. /&%]); } # Value elsif (/^(value)$/i) { $D{value} = substr( $self->percent_encoding( $self->percent_decoding($C{$1} ), q[^\w*-. /&%]), 0, 4095 - length($D{name})); } # Domain elsif (/^(domain)$/i) { $D{domain} = lc(".". $1), $D{domain} =~ s/^\.\././ if $C{$1} =~ /^($d_reg)$/; } # Path elsif (/^(path)$/i) { $D{path} = $self->percent_encoding($1, q[^\w*-. /&%]) if $C{$1} =~ /^($p_reg)$/; } # Max-Age elsif (/^(max[_-]age)$/i) { $D{expires} = time + $C{$1}; } # Expires elsif (/^(expires)$/i and not $D{expires}) { $D{expires} = $self->date_to_epoch($C{$1}); } } $D{expires} = time + $self->timeout unless $D{expires}; $D{domain} = ".". $self->url('host') unless $D{domain}; $D{path} = $self->url('epath') || '/' unless $D{path}; $D{name} && $D{value} ? %D : return; } ############################################################ # Accept-* ヘッダ sub accept ($;$) { ############################## my $self = shift; my $hash = $_[0]; my %hash = ref $hash eq 'HASH' ? %$hash : @_; my($key, $name); foreach $key (keys %hash) { my $value; my $q = 1; foreach (@{$hash{$key}}) { $value .= (not $value) ? $_ : ", $_;q=$q"; $q -= 0.1 if $q > 0.1; } if ($key =~ /^-type$/i) { $name = 'Accept'; } elsif ($key =~ /^-char$/i) { $name = 'Accept-Charset'; } elsif ($key =~ /^-lang$/i) { $name = 'Accept-Language'; } else { $key =~ s/^-//, $name = 'Accept-' . $key; } $self->header({$name => $value}); } } #********************************************************************* # Date/Time Formats ############################################################ # エポック秒からRFC1123 形式日付への変換 sub epoch_to_rfc1123date ($;$) { ############################## my $self = shift; my $time = shift || time; my $gmt = gmtime($time); my @wday = qw(Sun Mon Tue Wed Thu Fri Sat); my @mon = qw(Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec); sprintf( "%s, %02d %s %04d %02d:%02d:%02d GMT", $wday[$gmt->wday], $gmt->mday, $mon[$gmt->mon], $gmt->year +1900, $gmt->hour, $gmt->min, $gmt->sec ); } ############################################################ # HTTP 日付からエポック秒への変換 sub date_to_epoch ($$) { ############################## my $self = shift; my $date = shift; my %month = (Jan => 0, Feb => 1, Mar => 2, Apr => 3, May => 4, Jun => 5, Jul => 6, Aug => 7, Sep => 8, Oct => 9, Nov => 10, Dec => 11); my $w_exp = q{(?:Mon(?:day)?|Tue(?:sday)?|Wed(?:nesday)?|Thu(?:rsday)?|Fri(?:day)?|Sat(?:urday)?|Sun(?:day)?)}; my $d_exp = q{([ 0]?[1-9]|[12][0-9]|3[01])}; my $m_exp = q{(Jan|Feb|Mar|Apr|May|Jun|Jul|Aug|Sep|Oct|Nov|Dec)}; my $y_exp = q{((?:19|[2-9][0-9])?[0-9][0-9])}; my $t_exp = q{([ 01]?[0-9]|2[0-3]):([ 0-5]?[0-9]):([ 0-5]?[0-9])}; my($sec, $min, $hour, $mday, $month, $year); # RFC1123 形式 / Netscape-Cookies 形式日付 ( ($mday, $month, $year, $hour, $min, $sec) = $date =~ /^$w_exp, $d_exp[ -]$m_exp[ -]$y_exp $t_exp GMT$/ ) || # RFC850 形式日付 ( ($mday, $month, $year, $hour, $min, $sec) = $date =~ /^$w_exp, $d_exp-$m_exp-$y_exp $t_exp GMT$/ ) || # asctime() 形式日付 ( ($month, $mday, $hour, $min, $sec, $year) = $date =~ /^$w_exp $m_exp $d_exp $t_exp $y_exp$/ ) || # それ以外の形式には未対応 return; # Time::Local.pm を使ってエポック秒を返す timegm($sec, $min, $hour, $mday, $month{$month}, $year); } #********************************************************************* # Others ############################################################ sub md5 ($$) { ############################## my $self = shift; Digest::MD5->new->add(shift)->hexdigest; } ############################################################ # Base64 エンコーディング sub encode_base64 ($$) { ############################## my $self = shift; MIME::Base64::encode(shift, ""); } ############################################################ # Base64 デコーディング sub decode_base64 ($$) { ############################## my $self = shift; MIME::Base64::decode(shift); } ############################################################ # リクエストのタイムアウト値の設定 sub timeout ($;$) { ############################## my $self = shift; my $value = shift; $self->{_timeout} = $value if $value =~ /^\d+$/; $self->{_timeout}; } ############################################################ # リダイレクト回数の設定 sub redirection_times ($;$) { ############################## my $self = shift; my $value = shift; $self->{_redirect} = $value if $value =~ /^-?\d+$/; $self->{_redirect}; } ############################################################ # HTTP クッキー用ファイルの設定 sub cookies_file ($;$) { ############################## my $self = shift; my $value = shift; if ($value eq 'X') { $self->{_cookies_file} = undef; } elsif ($value) { $self->{_cookies_file} = $value; } $self->{_cookies_file}; } ############################################################ # プロクシの設定 sub proxy ($;$) { ############################## my $self = shift; my $value = shift; if ($value eq 'X') { delete $self->{_proxy}; } elsif ($value) { my $obj = _parse_url( $value =~ m|^http://+|i ? $value : 'http://'. $value ); $self->{_proxy} = $obj->{netloc} if $obj->{netloc}; } $self->{_proxy}; } #********************************************************************* 1;