1# ----------------------------------------------------------------------------- 2# $Id: Socket.pm 13831 2008-06-13 14:01:33Z topia $ 3# ----------------------------------------------------------------------------- 4# Socket Wrapper 5# 注意: Win32 環境では Socket 以外のファイルハンドル等に select を使えません。 6# (see perlport) 7# ----------------------------------------------------------------------------- 8# copyright (C) 2004 Topia <topia@clovery.jp>. all rights reserved. 9package Tiarra::Socket; 10use strict; 11use warnings; 12use Carp; 13use Tiarra::Utils; 14#use RunLoop; # lazy loading 15use Socket; 16our $is_winsock = $^O =~ /^MSWin32/; 17utils->define_attr_getter(0, qw(sock installed)); 18utils->define_attr_accessor(0, qw(name), 19 map { ["_$_", $_] } 20 qw(sock installed)); 21 22sub new { 23 my ($class, %opts) = @_; 24 25 my $this = { 26 runloop => $opts{runloop}, 27 installed => 0, 28 sock => undef, 29 name => utils->get_first_defined( 30 $opts{name}, 31 utils->simple_caller_formatter( 32 utils->get_first_defined($opts{_subject}, 'socket').' registered', 33 ($opts{_caller} || 0))), 34 }; 35 if (!defined $this->{runloop}) { 36 require RunLoop; 37 } 38 bless $this, $class; 39} 40 41sub runloop { 42 my $this = shift; 43 44 utils->get_first_defined($this->{runloop}, RunLoop->shared); 45} 46 47sub attach { 48 my ($this, $sock) = @_; 49 50 if ($this->installed) { 51 croak "already installed; can't attach!"; 52 } 53 54 return undef unless defined $sock; 55 $sock->autoflush(1); 56 $this->_sock($sock); 57 $this; 58} 59 60sub detach { 61 my $this = shift; 62 63 if (!defined $this->sock) { 64 croak "already detached; can't detach!"; 65 } 66 if ($this->installed) { 67 carp "installed; anyway detach..."; 68 $this->uninstall; 69 } 70 71 $this->_sock(undef); 72 $this; 73} 74 75sub close { 76 my $this = shift; 77 78 if (!defined $this->sock) { 79 croak "already detached; can't close!"; 80 } 81 82 $this->shutdown(2); 83 $this->detach; 84} 85 86sub shutdown { 87 my ($this, $type) = @_; 88 89 if (!defined $this->sock) { 90 croak "already detached; can't shutdown!"; 91 } 92 93 $this->sock->shutdown($type); 94} 95 96sub install { 97 my $this = shift; 98 99 if ($this->installed) { 100 croak "already installed; module bug?"; 101 } 102 103 $this->runloop->install_socket($this); 104 $this->_installed(1); 105 $this; 106} 107 108sub uninstall { 109 my $this = shift; 110 111 if (!$this->installed) { 112 croak "already uninstalled; module bug?"; 113 } 114 115 $this->runloop->uninstall_socket($this); 116 $this->_installed(0); 117 $this; 118} 119 120sub errno { 121 my $this = shift; 122 123 if (!defined $this->sock) { 124 croak "already detached; can't fetch errno!"; 125 } 126 127 my $errno = $this->sock->sockopt(SO_ERROR); 128 if ($errno == 0 || $errno == -1) { 129 $errno = undef; 130 } 131 return $errno; 132} 133 134sub errmsg { 135 my $this = shift; 136 my $errno = $this->errno; 137 my $msg = undef; 138 139 if (defined $errno) { 140 $msg = $this->sock_errno_to_msg($errno, @_); 141 } 142 if (wantarray) { 143 ($msg, $errno); 144 } else { 145 $msg; 146 } 147} 148 149sub _should_define { 150 die 'method should define! ('.shift->name.')'; 151} 152 153sub want_to_write { shift->_should_define } 154sub write { shift->_should_define } 155sub read { shift->_should_define } 156sub exception { shift->_should_define } 157 158# class method 159 160sub repr_destination { 161 my ($class_or_this, %data) = @_; 162 163 if (!defined $data{host} && defined $data{addr}) { 164 $data{host} = $data{addr}; 165 delete $data{addr}; 166 } 167 if (defined $data{host} && defined $data{addr} && 168 $data{host} eq $data{addr}) { 169 delete $data{addr}; 170 } 171 172 my $str = ''; 173 my $append_as_delimiter = sub { 174 $str .= shift if length $str; 175 }; 176 $str .= utils->to_str($data{host}); 177 $str .= "($data{addr})" if defined $data{addr}; 178 if (defined $data{port}) { 179 $append_as_delimiter->('/'); 180 $str .= $data{port}; 181 } 182 if (defined $data{type}) { 183 $append_as_delimiter->(' ('); 184 $str .= $class_or_this->repr_type($data{type}) . 185 (length $str ? ')' : ''); 186 } 187 $str; 188} 189 190sub repr_type { 191 my ($class_or_this, $type) = @_; 192 193 if ($type =~ /^ipv(\d+)$/i) { 194 return "IPv$1"; 195 } elsif ($type =~ /^unix$/i) { 196 return "Unix"; 197 } else { 198 return "Unknown: $type"; 199 } 200} 201 202sub probe_type_by_class { 203 my ($class_or_this, $obj) = @_; 204 205 map { 206 if (!wantarray) { 207 return $_->[1]; 208 } else { 209 $_->[1]; 210 } 211 } grep { 212 UNIVERSAL::isa($obj, $_->[0]); 213 } map { 214 substr($_->[0],0,0) = 'IO::Socket::'; 215 $_; 216 } ([qw(INET ipv4)], [qw(INET6 ipv6)], [qw(UNIX unix)]); 217} 218 219sub probe_type_by_addr { 220 my ($class_or_this, $addr) = @_; 221 222 if ($addr =~ m/^(?:\d+\.){3}\d+$/) { 223 return 'ipv4'; 224 } elsif ($addr =~ m/^[0-9a-fA-F:]+$/) { 225 return 'ipv6'; 226 } else { 227 # maybe 228 return 'unix'; 229 } 230 231} 232 233sub sock_errno_to_msg { 234 my ($this, $errno, $msg) = @_; 235 236 local $! = $errno; 237 $errno = ($!+0); 238 my $errstr = "$!"; 239 if ($! eq 'Unknown error' && $this->_is_winsock) { 240 # try probe (for my ActivePerl v5.8.4 build 810) 241 require Tiarra::Socket::Win32Errno; 242 my $new_errstr = Tiarra::Socket::Win32Errno->fetch_description($errno); 243 if (defined $new_errstr) { 244 $errstr = $new_errstr; 245 } 246 } 247 return ((defined $msg && length $msg) ? ($msg . ': ') : '' ) . 248 "$errno: $errstr"; 249} 250 251sub _is_winsock { 252 return $is_winsock; 253} 254 255sub _increment_caller { 256 my ($class_or_this, $subject, $opts) = @_; 257 258 $opts->{_caller} = ($opts->{_caller} || 0) + 1; 259 $opts->{_subject} = utils->get_first_defined( 260 $opts->{_subject}, 261 $subject); 262 $opts; 263} 264 265sub module_destruct { 266 my ($this, $module) = @_; 267 268 eval { $this->detach; }; 269 undef $this->{runloop}; 270} 271 2721; 273 274=pod 275 276=head1 NAME 277 278Tiarra::Socket - Tiarra RunLoop based Socket Handler Base Class 279 280=head1 SYNOPSIS 281 282=over 283 284=item use L<Tiarra::Socket> 285 286 use Tiarra::Socket; 287 $socket = Tiarra::Socket->new(name => 'sample socket'); 288 $socket->attach($sock); 289 $socket->install; 290 $socket->uninstall; 291 $socket->shutdown(2); 292 $socket->detach; 293 $socket->close; 294 $errno = $socket->errno; 295 $msg = $socket->errmsg( [$additional_msg] ); 296 $type = Tiarra::Socket->probe_type_by_class($sock); 297 $type = Tiarra::Socket->probe_type_by_addr($addr); 298 Tiarra::Socket->repr_type( $type ); 299 Tiarra::Socket->repr_destination( [datas] ); 300 $is_winsock = Tiarra::Socket->_is_winsock; 301 $msg = Tiarra::Socket->sock_errno_to_msg($errno[, $additional_msg]); 302 303=item make subclass of L<Tiarra::Socket> 304 305 package Tiarra::SomeSocket; 306 use Tiarra::Socket; 307 use base qw(Tiarra::Socket); 308 309 sub new { 310 my ($class, %opts) = @_; 311 312 $class->_increment_caller('some-socket', \%opts); 313 my $this = $class->SUPER::new(%opts); 314 $this; 315 } 316 # some overrides and implements... 317 318=back 319 320=head1 DESCRIPTION 321 322L<Tiarra::Socket> provides RunLoop based event driven Socket I/O interface. 323 324=head1 CONSTRUCTOR 325 326=over 327 328=item C<< $socket = new( [OPTS] ) >> 329 330opts is options hash. 331parametors: 332 333 runloop Tiarra RunLoop 334 name Socket name for pretty-print 335 336=back 337 338=head1 METHODS 339 340=over 341 342=item C<< ->runloop >> 343 344return default runloop or specified runloop 345 346=item C<< ->attach >> 347 348attach sock to socket 349 350=item C<< ->detach >> 351 352detach sock from socket 353 354=item C<< ->close >> 355 356shutdown and detach socket 357 358=item C<< ->shutdown( HOW ) >> 359 360call shutdown for this socket. 361 362=item C<< ->install >> 363 364install socket to runloop 365 366=item C<< ->uninstall >> 367 368uninstall socket from runloop 369 370=item C<< ->sock >> 371 372return sock attached to socket 373 374=item C<< ->installed >> 375 376return true if socket installed to runloop 377 378=item C<< ->errno >> 379 380return socket errno with sockopt(and clear status). 381if errno not set, return undef. 382 383=item C<< ->errmsg( [MESSAGE] ) >> 384 385return socket error message with msg. 386on array context, return $errno as 2nd item, also. 387 388(implement likes 389C<< $this->sock_errno_to_msg($this->errno, [MESSAGE] ) >>.) 390 391=back 392 393=head1 CLASS METHODS 394 395=over 396 397=item C<< ->repr_destination( [DATAS] ) >> 398 399representation destination with DATAS hash. 400currently supported hash key: 401 402=over 403 404=item host 405 406hostname(maybe FQDN). 407 408=item addr 409 410Address(IPv[46] Address). 411 412=item port 413 414Port or UNIX Domain Socket path. 415 416=item type 417 418Socket type. try repr inside, you haven't necessary call C<< ->repr_type >>. 419 420=back 421 422=item C<< ->repr_type( TYPE ) >> 423 424Simple Pretty-printing type. such as: 425 426 ipv4 -> IPv4 427 ipv6 -> IPv6 428 unix -> Unix 429 430=item C<< ->probe_type_by_class( CLASS_OR_OBJECT ) >> 431 432Probe type by class or object. 433 434=item C<< ->probe_type_by_addr( ADDRESS ) >> 435 436Probe type by address. 437 438=item C<< ->sock_errno_to_msg( ERRNO[, MESSAGE] ) >> 439 440representation sock errno and message. 441 442=back 443 444=head1 METHODS OF PLEASE OVERRIDE BY SUBCLASS 445 446=over 447 448=item C<< ->want_to_write >> 449 450return true(1) on want to write(write buffer has data) 451 452=item C<< ->write >> 453 454called when select notified this socket is writable. 455 456=item C<< ->read >> 457 458called when select notified this socket is readable. 459 460=item C<< ->exception >> 461 462called when select notified this socket has exception. 463 464=back 465 466=head1 SEE ALSO 467 468L<Tiarra::Socket::Connect>: socket connector. 469 470L<Tiarra::Socket::Buffered>, L<Tiarra::Socket::Lined>: reader/writer. 471 472L<Tiarra::Socket::Win32Errno>: Win32 errno database. 473 474=head1 COPYRIGHT AND DISCLAIMERS 475 476Copyright (c) 2004 Topia. All rights reserved. 477 478This library is free software; you can redistribute it and/or modify it 479under the same terms as Perl itself. 480 481This program is distributed in the hope that it will be useful, but 482without any warranty; without even the implied warranty of 483merchantability or fitness for a particular purpose. 484 485=head1 AUTHOR 486 487Topia, and originally developed by phonohawk. 488 489=cut 490