1## ---------------------------------------------------------------------------- 2# Tools::HTTPServer. 3# ----------------------------------------------------------------------------- 4# Mastering programmed by YAMASHINA Hio 5# 6# Copyright 2008 YAMASHINA Hio 7# ----------------------------------------------------------------------------- 8# $Id: HTTPServer.pm 9215 2008-04-09 14:37:50Z hio $ 9# ----------------------------------------------------------------------------- 10package Tools::HTTPServer; 11use strict; 12use warnings; 13use Tiarra::Socket; 14use base 'Tiarra::Socket'; 15 16use Tools::HTTPServer::Client; 17use Module::Use qw(Tools::HTTPServer::Client); 18 19use Scalar::Util qw(weaken); 20 21our $DEBUG = 0; 22 231; 24 25# ----------------------------------------------------------------------------- 26# $pkg->new(). 27# 28sub new 29{ 30 my $pkg = shift; 31 my %opts = @_; 32 $pkg->_increment_caller(__PACKAGE__, \%opts); 33 my $this = $pkg->SUPER::new(%opts); 34 35 $this->{host} = undef; 36 $this->{port} = undef; 37 $this->{listen} = undef; 38 $this->{path} = undef; 39 40 $this->{clients} = []; 41 $this->{callback_object} = undef; 42 43 $this; 44} 45 46# ----------------------------------------------------------------------------- 47# (destructor). 48# 49sub DESTROY 50{ 51 my $this = shift; 52 if( $this->sock ) 53 { 54 $this->detach(); 55 } 56} 57 58# ----------------------------------------------------------------------------- 59# $obj->start(%opts). 60# Host: $host. 61# Port: $port. 62# Listen: $backlog. 63# 64sub start 65{ 66 my $this = shift; 67 my $opts = {@_}; 68 69 $this->{host} = $opts->{Host} || '127.0.0.1'; 70 $this->{port} = $opts->{Port} || 8080; 71 $this->{listen} = $opts->{Listen} || 5; 72 73 # 処理するパス. 74 # /path/to/process/ の最初も最後も / がついている形に正規化. 75 my $path = $opts->{Path} || '/'; 76 $path =~ m{^/} or $path = "/$path"; 77 $path =~ m{/$} or $path = "$path/"; 78 $this->{path} = $path; 79 80 $this->{callback_object} = $opts->{CallbackObject}; 81 if( !$opts->{CallbackObjectNoWeaken} ) 82 { 83 weaken($this->{callback_object}); 84 } 85 86 my $sock = IO::Socket::INET->new( 87 LocalHost => $this->{host}, 88 LocalPort => $this->{port}, 89 Listen => $this->{listen}, 90 ReuseAddr => 1, 91 ); 92 93 if( $sock ) 94 { 95 $this->attach($sock); 96 $this->install(); 97 98 my $pkg = ref($this); 99 my $name = $this->name; 100 my $where = $this->where; 101 $name =~ s/^(?:\Q$pkg\E)?/$pkg ($where)/; 102 $this->name($name); 103 } 104 105 $this; 106} 107 108# ----------------------------------------------------------------------------- 109# $loc = $obj->where(). 110# $loc = 'http://host:port/path/'. 111# 112sub where 113{ 114 my $this = shift; 115 if( $this->sock ) 116 { 117 my $host = $this->{host}; 118 my $port = $this->{port}; 119 my $path = $this->{path}; 120 "http://$host:$port$path"; 121 }else 122 { 123 undef; 124 } 125} 126 127# ----------------------------------------------------------------------------- 128# (impl:tiarra-socket) 129# 130sub want_to_write { 0 } 131#sub write {} # never used. 132#sub exception {} # never used. 133sub read 134{ 135 my $this = shift; 136 137 my $sock = $this->sock->accept(); 138 if( !$sock ) 139 { 140 RunLoop->shared_loop->notify_error(__PACKAGE__.", accept failed: $!/$@"); 141 return; 142 } 143 144 $this->_on_accept($sock); 145} 146 147sub close 148{ 149 my $this = shift; 150 $this->SUPER::close(@_); 151 152 my $list = $this->{clients}; 153 foreach my $cli (@$list) 154 { 155 $cli and $cli->close(); 156 } 157 @$list = (); 158} 159 160# ----------------------------------------------------------------------------- 161# $this->_on_accept($sock). 162# (private). 163# 164sub _on_accept 165{ 166 my $this = shift; 167 my $sock = shift; 168 169 # 接続元制限とかいれたければこのあたりでいれてもいいのかも? 170 171 $this->_start_client($sock); 172} 173 174# ----------------------------------------------------------------------------- 175# $this->_start_client($sock). 176# 177sub _start_client 178{ 179 my $this = shift; 180 my $sock = shift; 181 182 my $peer = $sock->peerhost.':'.$sock->peerport; 183 $DEBUG and $this->_debug("start client $peer"); 184 185 my $cli = Tools::HTTPServer::Client->new(); 186 push(@{$this->{clients}}, $cli); 187 188 $cli->start( 189 Socket => $sock, 190 CallbackObject => $this, 191 ); 192 193 $this; 194} 195 196# ----------------------------------------------------------------------------- 197# (impl:callback-from-Tools::HTTPServer::Client). 198# 199sub _on_request 200{ 201 my $this = shift; 202 my $cli = shift; 203 my $req = shift; 204 205 # このオブジェクトからのコールバックを起動. 206 my $par = $this->{callback_object}; 207 if( !$par ) 208 { 209 RunLoop->shared_loop->notify_error(__PACKAGE__."->_on_request(), no callback_object"); 210 return; 211 } 212 $par->_on_request($cli, $req); 213} 214 215# ----------------------------------------------------------------------------- 216# (impl:callback-from-Tools::HTTPServer::Client). 217# 218sub _on_close_client 219{ 220 my $this = shift; 221 my $cli = shift; 222 223 # 保持しているクライアント一覧から除去. 224 my $list = $this->{clients}; 225 @$list = grep { $_ && $_ ne $cli } @$list; 226 227 # このオブジェクトからのコールバックを起動. 228 my $par = $this->{callback_object}; 229 if( !$par ) 230 { 231 RunLoop->shared_loop->notify_error(__PACKAGE__."->_on_close_client(), no callback_object"); 232 return; 233 } 234 my $sub = $par->can('_on_close_client'); 235 if( $sub ) 236 { 237 $par->$sub($cli); 238 } 239} 240 241# ----------------------------------------------------------------------------- 242# $this->_debug($msg). 243# 244sub _debug 245{ 246 my $this = shift; 247 my $msg = shift; 248 RunLoop->shared_loop->notify_msg($msg); 249} 250 251 252# ----------------------------------------------------------------------------- 253# End of Module. 254# ----------------------------------------------------------------------------- 255# ----------------------------------------------------------------------------- 256# End of File. 257# ----------------------------------------------------------------------------- 258__END__ 259 260=encoding utf8 261 262=for stopwords 263 YAMASHINA 264 Hio 265 ACKNOWLEDGEMENTS 266 AnnoCPAN 267 CPAN 268 RT 269 270