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