PageRenderTime 46ms CodeModel.GetById 18ms RepoModel.GetById 1ms app.codeStats 0ms

/mojolegacy/lib/Mojo/IOLoop/Client.pm

http://github.com/yuki-kimoto/gitweblite
Perl | 258 lines | 176 code | 67 blank | 15 comment | 15 complexity | 3e02e2785e7ed67ab0fd39fee9681b6f MD5 | raw file
  1. package Mojo::IOLoop::Client;
  2. use Mojo::Base 'Mojo::EventEmitter';
  3. use IO::Socket::INET;
  4. use Scalar::Util 'weaken';
  5. use Socket qw/IPPROTO_TCP SO_ERROR TCP_NODELAY/;
  6. # IPv6 support requires IO::Socket::IP
  7. use constant IPV6 => $ENV{MOJO_NO_IPV6}
  8. ? 0
  9. : eval 'use IO::Socket::IP 0.06 (); 1';
  10. # TLS support requires IO::Socket::SSL
  11. use constant TLS => $ENV{MOJO_NO_TLS}
  12. ? 0
  13. : eval 'use IO::Socket::SSL 1.37 "inet4"; 1';
  14. use constant TLS_READ => TLS ? IO::Socket::SSL::SSL_WANT_READ() : 0;
  15. use constant TLS_WRITE => TLS ? IO::Socket::SSL::SSL_WANT_WRITE() : 0;
  16. # "It's like my dad always said: eventually, everybody gets shot."
  17. has reactor => sub {
  18. require Mojo::IOLoop;
  19. Mojo::IOLoop->singleton->reactor;
  20. };
  21. sub DESTROY { shift->_cleanup }
  22. # "I wonder where Bart is, his dinner's getting all cold... and eaten."
  23. sub connect {
  24. my $self = shift;
  25. my $args = ref $_[0] ? $_[0] : {@_};
  26. weaken $self;
  27. $self->{delay} = $self->reactor->timer(0 => sub { $self->_connect($args) });
  28. }
  29. sub _cleanup {
  30. my $self = shift;
  31. return unless my $reactor = $self->{reactor};
  32. $reactor->remove(delete $self->{delay}) if $self->{delay};
  33. $reactor->remove(delete $self->{timer}) if $self->{timer};
  34. $reactor->remove(delete $self->{handle}) if $self->{handle};
  35. }
  36. sub _connect {
  37. my ($self, $args) = @_;
  38. # New socket
  39. my $handle;
  40. my $reactor = $self->reactor;
  41. my $address = $args->{address} ||= 'localhost';
  42. unless ($handle = $args->{handle}) {
  43. my %options = (
  44. Blocking => 0,
  45. PeerAddr => $address eq 'localhost' ? '127.0.0.1' : $address,
  46. PeerPort => $args->{port} || ($args->{tls} ? 443 : 80),
  47. Proto => 'tcp'
  48. );
  49. $options{LocalAddr} = $args->{local_address} if $args->{local_address};
  50. $options{PeerAddr} =~ s/[\[\]]//g if $options{PeerAddr};
  51. my $class = IPV6 ? 'IO::Socket::IP' : 'IO::Socket::INET';
  52. return $self->emit_safe(error => "Couldn't connect.")
  53. unless $handle = $class->new(%options);
  54. # Timer
  55. $self->{timer} = $reactor->timer($args->{timeout} || 10,
  56. sub { $self->emit_safe(error => 'Connect timeout.') });
  57. # IPv6 needs an early start
  58. $handle->connect if IPV6;
  59. }
  60. $handle->blocking(0);
  61. # Disable Nagle's algorithm
  62. setsockopt $handle, IPPROTO_TCP, TCP_NODELAY, 1;
  63. # TLS
  64. weaken $self;
  65. if ($args->{tls}) {
  66. # No TLS support
  67. return $self->emit_safe(
  68. error => 'IO::Socket::SSL 1.37 required for TLS support.')
  69. unless TLS;
  70. # Upgrade
  71. my %options = (
  72. SSL_ca_file => $args->{tls_ca}
  73. && -T $args->{tls_ca} ? $args->{tls_ca} : undef,
  74. SSL_cert_file => $args->{tls_cert},
  75. SSL_error_trap => sub {
  76. $self->_cleanup;
  77. $self->emit_safe(error => $_[1]);
  78. },
  79. SSL_hostname => $args->{address},
  80. SSL_key_file => $args->{tls_key},
  81. SSL_startHandshake => 0,
  82. SSL_verify_mode => $args->{tls_ca} ? 0x01 : 0x00,
  83. SSL_verifycn_name => $args->{address},
  84. SSL_verifycn_scheme => $args->{tls_ca} ? 'http' : undef
  85. );
  86. $self->{tls} = 1;
  87. return $self->emit_safe(error => 'TLS upgrade failed.')
  88. unless $handle = IO::Socket::SSL->start_SSL($handle, %options);
  89. }
  90. # Wait for handle to become writable
  91. $self->{handle} = $handle;
  92. $reactor->io($handle => sub { $self->_connecting })->watch($handle, 0, 1);
  93. }
  94. # "Have you ever seen that Blue Man Group? Total ripoff of the Smurfs.
  95. # And the Smurfs, well, they SUCK."
  96. sub _connecting {
  97. my $self = shift;
  98. # Switch between reading and writing
  99. my $handle = $self->{handle};
  100. my $reactor = $self->reactor;
  101. if ($self->{tls} && !$handle->connect_SSL) {
  102. my $err = $IO::Socket::SSL::SSL_ERROR;
  103. if ($err == TLS_READ) { $reactor->watch($handle, 1, 0) }
  104. elsif ($err == TLS_WRITE) { $reactor->watch($handle, 1, 1) }
  105. return;
  106. }
  107. # Check for errors
  108. return $self->emit_safe(error => $! = $handle->sockopt(SO_ERROR))
  109. unless $handle->connected;
  110. # Connected
  111. $self->_cleanup;
  112. $self->emit_safe(connect => $handle);
  113. }
  114. 1;
  115. __END__
  116. =head1 NAME
  117. Mojo::IOLoop::Client - Non-blocking TCP client
  118. =head1 SYNOPSIS
  119. use Mojo::IOLoop::Client;
  120. # Create socket connection
  121. my $client = Mojo::IOLoop::Client->new;
  122. $client->on(connect => sub {
  123. my ($client, $handle) = @_;
  124. ...
  125. });
  126. $client->on(error => sub {
  127. my ($client, $err) = @_;
  128. ...
  129. });
  130. $client->connect(address => 'mojolicio.us', port => 80);
  131. =head1 DESCRIPTION
  132. L<Mojo::IOLoop::Client> opens TCP connections for L<Mojo::IOLoop>.
  133. =head1 EVENTS
  134. L<Mojo::IOLoop::Client> can emit the following events.
  135. =head2 C<connect>
  136. $client->on(connect => sub {
  137. my ($client, $handle) = @_;
  138. ...
  139. });
  140. Emitted safely once the connection is established.
  141. =head2 C<error>
  142. $client->on(error => sub {
  143. my ($client, $err) = @_;
  144. ...
  145. });
  146. Emitted safely if an error happens on the connection.
  147. =head1 ATTRIBUTES
  148. L<Mojo::IOLoop::Client> implements the following attributes.
  149. =head2 C<reactor>
  150. my $reactor = $client->reactor;
  151. $client = $client->reactor(Mojo::Reactor::Poll->new);
  152. Low level event reactor, defaults to the C<reactor> attribute value of the
  153. global L<Mojo::IOLoop> singleton.
  154. =head1 METHODS
  155. L<Mojo::IOLoop::Client> inherits all methods from L<Mojo::EventEmitter> and
  156. implements the following new ones.
  157. =head2 C<connect>
  158. $client->connect(
  159. address => '127.0.0.1',
  160. port => 3000
  161. );
  162. Open a socket connection to a remote host. Note that TLS support depends on
  163. L<IO::Socket::SSL> and IPv6 support on L<IO::Socket::IP>.
  164. These options are currently available:
  165. =over 2
  166. =item C<address>
  167. Address or host name of the peer to connect to, defaults to C<localhost>.
  168. =item C<handle>
  169. Use an already prepared handle.
  170. =item C<local_address>
  171. Local address to bind to.
  172. =item C<port>
  173. Port to connect to.
  174. =item C<timeout>
  175. Maximum amount of time in seconds establishing connection may take before
  176. getting canceled, defaults to C<10>.
  177. =item C<tls>
  178. Enable TLS.
  179. =item C<tls_ca>
  180. Path to TLS certificate authority file. Also activates hostname verification.
  181. =item C<tls_cert>
  182. Path to the TLS certificate file.
  183. =item C<tls_key>
  184. Path to the TLS key file.
  185. =back
  186. =head1 SEE ALSO
  187. L<Mojolicious>, L<Mojolicious::Guides>, L<http://mojolicio.us>.
  188. =cut