├── .gitignore ├── Build.PL ├── Changes ├── LICENSE ├── MANIFEST.SKIP ├── META.json ├── README.md ├── cpanfile ├── examples ├── chat │ ├── README │ ├── chat-redis.psgi │ ├── chat-rooms.psgi │ ├── chat.psgi │ └── public │ │ ├── WebSocketMain.swf │ │ ├── WebSocketMainInsecure.swf │ │ ├── chat.html │ │ ├── socket.io.js │ │ └── stylesheets │ │ └── style.css └── flash-policy-server ├── lib ├── PocketIO.pm └── PocketIO │ ├── Broadcast.pm │ ├── Connection.pm │ ├── Exception.pm │ ├── Handle.pm │ ├── Message.pm │ ├── Pool.pm │ ├── Pool │ └── Redis.pm │ ├── Resource.pm │ ├── Room.pm │ ├── Socket.pm │ ├── Sockets.pm │ ├── Test.pm │ ├── Transport │ ├── Base.pm │ ├── BasePolling.pm │ ├── Htmlfile.pm │ ├── JSONPPolling.pm │ ├── WebSocket.pm │ ├── XHRMultipart.pm │ └── XHRPolling.pm │ └── Util.pm ├── minil.toml ├── t ├── app.t ├── conn │ ├── broadcast.t │ ├── close-timeout.t │ ├── connect-timeout.t │ ├── parsing.t │ ├── reconnect-timeout.t │ ├── socket.t │ └── sockets.t ├── lib │ └── Handler.pm ├── pool.t ├── resource.t ├── room.t └── transport │ ├── htmlfile.t │ ├── jsonp-polling.t │ ├── websocket.t │ └── xhr-polling.t └── xt ├── changes.t ├── pod-coverage.t └── pod.t /.gitignore: -------------------------------------------------------------------------------- 1 | Makefile 2 | blib 3 | *.swp 4 | *~ 5 | pm_to_blib 6 | -------------------------------------------------------------------------------- /Build.PL: -------------------------------------------------------------------------------- 1 | # ========================================================================= 2 | # THIS FILE IS AUTOMATICALLY GENERATED BY MINILLA. 3 | # DO NOT EDIT DIRECTLY. 4 | # ========================================================================= 5 | 6 | use 5.008_001; 7 | 8 | use strict; 9 | use warnings; 10 | use utf8; 11 | 12 | use Module::Build; 13 | use File::Basename; 14 | use File::Spec; 15 | use CPAN::Meta; 16 | use CPAN::Meta::Prereqs; 17 | 18 | my %args = ( 19 | license => 'perl', 20 | dynamic_config => 0, 21 | 22 | configure_requires => { 23 | 'Module::Build' => 0.38, 24 | }, 25 | 26 | name => 'PocketIO', 27 | module_name => 'PocketIO', 28 | allow_pureperl => 0, 29 | 30 | script_files => [glob('script/*'), glob('bin/*')], 31 | c_source => [qw()], 32 | PL_files => {}, 33 | 34 | test_files => ((-d '.git' || $ENV{RELEASE_TESTING}) && -d 'xt') ? 't/ xt/' : 't/', 35 | recursive_test_files => 1, 36 | 37 | ); 38 | if (-d 'share') { 39 | $args{share_dir} = 'share'; 40 | } 41 | 42 | my $builder = Module::Build->subclass( 43 | class => 'MyBuilder', 44 | code => q{ 45 | sub ACTION_distmeta { 46 | die "Do not run distmeta. Install Minilla and `minil install` instead.\n"; 47 | } 48 | sub ACTION_installdeps { 49 | die "Do not run installdeps. Run `cpanm --installdeps .` instead.\n"; 50 | } 51 | } 52 | )->new(%args); 53 | $builder->create_build_script(); 54 | 55 | my $mbmeta = CPAN::Meta->load_file('MYMETA.json'); 56 | my $meta = CPAN::Meta->load_file('META.json'); 57 | my $prereqs_hash = CPAN::Meta::Prereqs->new( 58 | $meta->prereqs 59 | )->with_merged_prereqs( 60 | CPAN::Meta::Prereqs->new($mbmeta->prereqs) 61 | )->as_string_hash; 62 | my $mymeta = CPAN::Meta->new( 63 | { 64 | %{$meta->as_struct}, 65 | prereqs => $prereqs_hash 66 | } 67 | ); 68 | print "Merging cpanfile prereqs to MYMETA.yml\n"; 69 | $mymeta->save('MYMETA.yml', { version => 1.4 }); 70 | print "Merging cpanfile prereqs to MYMETA.json\n"; 71 | $mymeta->save('MYMETA.json', { version => 2 }); 72 | -------------------------------------------------------------------------------- /Changes: -------------------------------------------------------------------------------- 1 | Revision history for perl module PocketIO 2 | 3 | {{$NEXT}} 4 | 5 | 0.17 2014-01-07T20:29:26Z 6 | 7 | - just meta files update 8 | 9 | 0.16 2013-10-25T16:55:13Z 10 | 11 | - Fixed bug when attempting to broadcast->send (mvgrimes) 12 | - support method other than 'run' (tokubass) 13 | 14 | 0.15 2012-12-30 15 | 16 | - Fixed room stringification problem (Peter Stuifzand) 17 | - Skip hanging test on windows 18 | 19 | 0.14 2012-06-05 20 | 21 | - Fixed exception handling bugs (Jason May) 22 | - Provide the status code when throwing a websocket exception (Jason May) 23 | - Added room support (Michael FiG) 24 | 25 | 0.12 2012-01-25 26 | 27 | - Fixed test requirements 28 | 29 | 0.11 2012-01-24 30 | 31 | - Fixed modules requirements 32 | 33 | 0.10 2012-01-22 34 | 35 | - Plack::Request is not required 36 | - Twiggy is not required for testing 37 | - Extracted SocketIO protocol into a separated distribution 38 | - Return raw object but wrap exceptions middelware on the fly 39 | - Fixed on_disconnect callback 40 | 41 | 0.009008 2011-12-06 42 | 43 | - Fixed websocket test 44 | 45 | 0.009007 2011-12-03 46 | 47 | - Fixed CPAN dist 48 | 49 | 0.009006 2011-12-02 50 | 51 | - Made message parsing more robust. Closes #GH-10 52 | - Socket emit should emit client event not server 53 | - Use exceptions 54 | - Updated socket.io.js in example 55 | - Increased connection timeout 56 | - Require Protocol::WebSocket 0.9.5 57 | - Increased connection timeout to 30s 58 | 59 | 0.009005 2011-09-23 60 | 61 | - CPAN release 62 | - Redis pool backend 63 | - Socket.IO 0.8 version support 64 | 65 | 0.009004 2011-05-12 66 | 67 | - Renamed to PocketIO 68 | - Implemented as a Plack app instead of middleware 69 | - Fixed UTF issues 70 | 71 | 0.009003 2011-04-09 72 | 73 | - It is possible to pass class name or instance and method instead of inline 74 | handler 75 | - Added heartbeat to WebSockets too 76 | 77 | 0.009002 2011-03-29 78 | 79 | - Fixed live tests 80 | 81 | 0.009001 2011-03-28 82 | 83 | - Fixed dependencies list 84 | 85 | 0.009000 2011-03-16 86 | 87 | - Initial release 88 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | This software is copyright (c) 2013 by Viacheslav Tykhanovskyi 2 | . 3 | 4 | This is free software; you can redistribute it and/or modify it under 5 | the same terms as the Perl 5 programming language system itself. 6 | 7 | Terms of the Perl programming language system itself 8 | 9 | a) the GNU General Public License as published by the Free 10 | Software Foundation; either version 1, or (at your option) any 11 | later version, or 12 | b) the "Artistic License" 13 | 14 | --- The GNU General Public License, Version 1, February 1989 --- 15 | 16 | This software is copyright (c) 2013 by Viacheslav Tykhanovskyi 17 | . 18 | 19 | This is free software, licensed under: 20 | 21 | The GNU General Public License, Version 1, February 1989 22 | 23 | GNU GENERAL PUBLIC LICENSE 24 | Version 1, February 1989 25 | 26 | Copyright (C) 1989 Free Software Foundation, Inc. 27 | 51 Franklin St, Suite 500, Boston, MA 02110-1335 USA 28 | 29 | Everyone is permitted to copy and distribute verbatim copies 30 | of this license document, but changing it is not allowed. 31 | 32 | Preamble 33 | 34 | The license agreements of most software companies try to keep users 35 | at the mercy of those companies. By contrast, our General Public 36 | License is intended to guarantee your freedom to share and change free 37 | software--to make sure the software is free for all its users. The 38 | General Public License applies to the Free Software Foundation's 39 | software and to any other program whose authors commit to using it. 40 | You can use it for your programs, too. 41 | 42 | When we speak of free software, we are referring to freedom, not 43 | price. Specifically, the General Public License is designed to make 44 | sure that you have the freedom to give away or sell copies of free 45 | software, that you receive source code or can get it if you want it, 46 | that you can change the software or use pieces of it in new free 47 | programs; and that you know you can do these things. 48 | 49 | To protect your rights, we need to make restrictions that forbid 50 | anyone to deny you these rights or to ask you to surrender the rights. 51 | These restrictions translate to certain responsibilities for you if you 52 | distribute copies of the software, or if you modify it. 53 | 54 | For example, if you distribute copies of a such a program, whether 55 | gratis or for a fee, you must give the recipients all the rights that 56 | you have. You must make sure that they, too, receive or can get the 57 | source code. And you must tell them their rights. 58 | 59 | We protect your rights with two steps: (1) copyright the software, and 60 | (2) offer you this license which gives you legal permission to copy, 61 | distribute and/or modify the software. 62 | 63 | Also, for each author's protection and ours, we want to make certain 64 | that everyone understands that there is no warranty for this free 65 | software. If the software is modified by someone else and passed on, we 66 | want its recipients to know that what they have is not the original, so 67 | that any problems introduced by others will not reflect on the original 68 | authors' reputations. 69 | 70 | The precise terms and conditions for copying, distribution and 71 | modification follow. 72 | 73 | GNU GENERAL PUBLIC LICENSE 74 | TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION 75 | 76 | 0. This License Agreement applies to any program or other work which 77 | contains a notice placed by the copyright holder saying it may be 78 | distributed under the terms of this General Public License. The 79 | "Program", below, refers to any such program or work, and a "work based 80 | on the Program" means either the Program or any work containing the 81 | Program or a portion of it, either verbatim or with modifications. Each 82 | licensee is addressed as "you". 83 | 84 | 1. You may copy and distribute verbatim copies of the Program's source 85 | code as you receive it, in any medium, provided that you conspicuously and 86 | appropriately publish on each copy an appropriate copyright notice and 87 | disclaimer of warranty; keep intact all the notices that refer to this 88 | General Public License and to the absence of any warranty; and give any 89 | other recipients of the Program a copy of this General Public License 90 | along with the Program. You may charge a fee for the physical act of 91 | transferring a copy. 92 | 93 | 2. You may modify your copy or copies of the Program or any portion of 94 | it, and copy and distribute such modifications under the terms of Paragraph 95 | 1 above, provided that you also do the following: 96 | 97 | a) cause the modified files to carry prominent notices stating that 98 | you changed the files and the date of any change; and 99 | 100 | b) cause the whole of any work that you distribute or publish, that 101 | in whole or in part contains the Program or any part thereof, either 102 | with or without modifications, to be licensed at no charge to all 103 | third parties under the terms of this General Public License (except 104 | that you may choose to grant warranty protection to some or all 105 | third parties, at your option). 106 | 107 | c) If the modified program normally reads commands interactively when 108 | run, you must cause it, when started running for such interactive use 109 | in the simplest and most usual way, to print or display an 110 | announcement including an appropriate copyright notice and a notice 111 | that there is no warranty (or else, saying that you provide a 112 | warranty) and that users may redistribute the program under these 113 | conditions, and telling the user how to view a copy of this General 114 | Public License. 115 | 116 | d) You may charge a fee for the physical act of transferring a 117 | copy, and you may at your option offer warranty protection in 118 | exchange for a fee. 119 | 120 | Mere aggregation of another independent work with the Program (or its 121 | derivative) on a volume of a storage or distribution medium does not bring 122 | the other work under the scope of these terms. 123 | 124 | 3. You may copy and distribute the Program (or a portion or derivative of 125 | it, under Paragraph 2) in object code or executable form under the terms of 126 | Paragraphs 1 and 2 above provided that you also do one of the following: 127 | 128 | a) accompany it with the complete corresponding machine-readable 129 | source code, which must be distributed under the terms of 130 | Paragraphs 1 and 2 above; or, 131 | 132 | b) accompany it with a written offer, valid for at least three 133 | years, to give any third party free (except for a nominal charge 134 | for the cost of distribution) a complete machine-readable copy of the 135 | corresponding source code, to be distributed under the terms of 136 | Paragraphs 1 and 2 above; or, 137 | 138 | c) accompany it with the information you received as to where the 139 | corresponding source code may be obtained. (This alternative is 140 | allowed only for noncommercial distribution and only if you 141 | received the program in object code or executable form alone.) 142 | 143 | Source code for a work means the preferred form of the work for making 144 | modifications to it. For an executable file, complete source code means 145 | all the source code for all modules it contains; but, as a special 146 | exception, it need not include source code for modules which are standard 147 | libraries that accompany the operating system on which the executable 148 | file runs, or for standard header files or definitions files that 149 | accompany that operating system. 150 | 151 | 4. You may not copy, modify, sublicense, distribute or transfer the 152 | Program except as expressly provided under this General Public License. 153 | Any attempt otherwise to copy, modify, sublicense, distribute or transfer 154 | the Program is void, and will automatically terminate your rights to use 155 | the Program under this License. However, parties who have received 156 | copies, or rights to use copies, from you under this General Public 157 | License will not have their licenses terminated so long as such parties 158 | remain in full compliance. 159 | 160 | 5. By copying, distributing or modifying the Program (or any work based 161 | on the Program) you indicate your acceptance of this license to do so, 162 | and all its terms and conditions. 163 | 164 | 6. Each time you redistribute the Program (or any work based on the 165 | Program), the recipient automatically receives a license from the original 166 | licensor to copy, distribute or modify the Program subject to these 167 | terms and conditions. You may not impose any further restrictions on the 168 | recipients' exercise of the rights granted herein. 169 | 170 | 7. The Free Software Foundation may publish revised and/or new versions 171 | of the General Public License from time to time. Such new versions will 172 | be similar in spirit to the present version, but may differ in detail to 173 | address new problems or concerns. 174 | 175 | Each version is given a distinguishing version number. If the Program 176 | specifies a version number of the license which applies to it and "any 177 | later version", you have the option of following the terms and conditions 178 | either of that version or of any later version published by the Free 179 | Software Foundation. If the Program does not specify a version number of 180 | the license, you may choose any version ever published by the Free Software 181 | Foundation. 182 | 183 | 8. If you wish to incorporate parts of the Program into other free 184 | programs whose distribution conditions are different, write to the author 185 | to ask for permission. For software which is copyrighted by the Free 186 | Software Foundation, write to the Free Software Foundation; we sometimes 187 | make exceptions for this. Our decision will be guided by the two goals 188 | of preserving the free status of all derivatives of our free software and 189 | of promoting the sharing and reuse of software generally. 190 | 191 | NO WARRANTY 192 | 193 | 9. BECAUSE THE PROGRAM IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTY 194 | FOR THE PROGRAM, TO THE EXTENT PERMITTED BY APPLICABLE LAW. EXCEPT WHEN 195 | OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES 196 | PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHER EXPRESSED 197 | OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF 198 | MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. THE ENTIRE RISK AS 199 | TO THE QUALITY AND PERFORMANCE OF THE PROGRAM IS WITH YOU. SHOULD THE 200 | PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL NECESSARY SERVICING, 201 | REPAIR OR CORRECTION. 202 | 203 | 10. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING 204 | WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY AND/OR 205 | REDISTRIBUTE THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, 206 | INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING 207 | OUT OF THE USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED 208 | TO LOSS OF DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY 209 | YOU OR THIRD PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER 210 | PROGRAMS), EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE 211 | POSSIBILITY OF SUCH DAMAGES. 212 | 213 | END OF TERMS AND CONDITIONS 214 | 215 | Appendix: How to Apply These Terms to Your New Programs 216 | 217 | If you develop a new program, and you want it to be of the greatest 218 | possible use to humanity, the best way to achieve this is to make it 219 | free software which everyone can redistribute and change under these 220 | terms. 221 | 222 | To do so, attach the following notices to the program. It is safest to 223 | attach them to the start of each source file to most effectively convey 224 | the exclusion of warranty; and each file should have at least the 225 | "copyright" line and a pointer to where the full notice is found. 226 | 227 | 228 | Copyright (C) 19yy 229 | 230 | This program is free software; you can redistribute it and/or modify 231 | it under the terms of the GNU General Public License as published by 232 | the Free Software Foundation; either version 1, or (at your option) 233 | any later version. 234 | 235 | This program is distributed in the hope that it will be useful, 236 | but WITHOUT ANY WARRANTY; without even the implied warranty of 237 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 238 | GNU General Public License for more details. 239 | 240 | You should have received a copy of the GNU General Public License 241 | along with this program; if not, write to the Free Software 242 | Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston MA 02110-1301 USA 243 | 244 | 245 | Also add information on how to contact you by electronic and paper mail. 246 | 247 | If the program is interactive, make it output a short notice like this 248 | when it starts in an interactive mode: 249 | 250 | Gnomovision version 69, Copyright (C) 19xx name of author 251 | Gnomovision comes with ABSOLUTELY NO WARRANTY; for details type `show w'. 252 | This is free software, and you are welcome to redistribute it 253 | under certain conditions; type `show c' for details. 254 | 255 | The hypothetical commands `show w' and `show c' should show the 256 | appropriate parts of the General Public License. Of course, the 257 | commands you use may be called something other than `show w' and `show 258 | c'; they could even be mouse-clicks or menu items--whatever suits your 259 | program. 260 | 261 | You should also get your employer (if you work as a programmer) or your 262 | school, if any, to sign a "copyright disclaimer" for the program, if 263 | necessary. Here a sample; alter the names: 264 | 265 | Yoyodyne, Inc., hereby disclaims all copyright interest in the 266 | program `Gnomovision' (a program to direct compilers to make passes 267 | at assemblers) written by James Hacker. 268 | 269 | , 1 April 1989 270 | Ty Coon, President of Vice 271 | 272 | That's all there is to it! 273 | 274 | 275 | --- The Artistic License 1.0 --- 276 | 277 | This software is copyright (c) 2013 by Viacheslav Tykhanovskyi 278 | . 279 | 280 | This is free software, licensed under: 281 | 282 | The Artistic License 1.0 283 | 284 | The Artistic License 285 | 286 | Preamble 287 | 288 | The intent of this document is to state the conditions under which a Package 289 | may be copied, such that the Copyright Holder maintains some semblance of 290 | artistic control over the development of the package, while giving the users of 291 | the package the right to use and distribute the Package in a more-or-less 292 | customary fashion, plus the right to make reasonable modifications. 293 | 294 | Definitions: 295 | 296 | - "Package" refers to the collection of files distributed by the Copyright 297 | Holder, and derivatives of that collection of files created through 298 | textual modification. 299 | - "Standard Version" refers to such a Package if it has not been modified, 300 | or has been modified in accordance with the wishes of the Copyright 301 | Holder. 302 | - "Copyright Holder" is whoever is named in the copyright or copyrights for 303 | the package. 304 | - "You" is you, if you're thinking about copying or distributing this Package. 305 | - "Reasonable copying fee" is whatever you can justify on the basis of media 306 | cost, duplication charges, time of people involved, and so on. (You will 307 | not be required to justify it to the Copyright Holder, but only to the 308 | computing community at large as a market that must bear the fee.) 309 | - "Freely Available" means that no fee is charged for the item itself, though 310 | there may be fees involved in handling the item. It also means that 311 | recipients of the item may redistribute it under the same conditions they 312 | received it. 313 | 314 | 1. You may make and give away verbatim copies of the source form of the 315 | Standard Version of this Package without restriction, provided that you 316 | duplicate all of the original copyright notices and associated disclaimers. 317 | 318 | 2. You may apply bug fixes, portability fixes and other modifications derived 319 | from the Public Domain or from the Copyright Holder. A Package modified in such 320 | a way shall still be considered the Standard Version. 321 | 322 | 3. You may otherwise modify your copy of this Package in any way, provided that 323 | you insert a prominent notice in each changed file stating how and when you 324 | changed that file, and provided that you do at least ONE of the following: 325 | 326 | a) place your modifications in the Public Domain or otherwise make them 327 | Freely Available, such as by posting said modifications to Usenet or an 328 | equivalent medium, or placing the modifications on a major archive site 329 | such as ftp.uu.net, or by allowing the Copyright Holder to include your 330 | modifications in the Standard Version of the Package. 331 | 332 | b) use the modified Package only within your corporation or organization. 333 | 334 | c) rename any non-standard executables so the names do not conflict with 335 | standard executables, which must also be provided, and provide a separate 336 | manual page for each non-standard executable that clearly documents how it 337 | differs from the Standard Version. 338 | 339 | d) make other distribution arrangements with the Copyright Holder. 340 | 341 | 4. You may distribute the programs of this Package in object code or executable 342 | form, provided that you do at least ONE of the following: 343 | 344 | a) distribute a Standard Version of the executables and library files, 345 | together with instructions (in the manual page or equivalent) on where to 346 | get the Standard Version. 347 | 348 | b) accompany the distribution with the machine-readable source of the Package 349 | with your modifications. 350 | 351 | c) accompany any non-standard executables with their corresponding Standard 352 | Version executables, giving the non-standard executables non-standard 353 | names, and clearly documenting the differences in manual pages (or 354 | equivalent), together with instructions on where to get the Standard 355 | Version. 356 | 357 | d) make other distribution arrangements with the Copyright Holder. 358 | 359 | 5. You may charge a reasonable copying fee for any distribution of this 360 | Package. You may charge any fee you choose for support of this Package. You 361 | may not charge a fee for this Package itself. However, you may distribute this 362 | Package in aggregate with other (possibly commercial) programs as part of a 363 | larger (possibly commercial) software distribution provided that you do not 364 | advertise this Package as a product of your own. 365 | 366 | 6. The scripts and library files supplied as input to or produced as output 367 | from the programs of this Package do not automatically fall under the copyright 368 | of this Package, but belong to whomever generated them, and may be sold 369 | commercially, and may be aggregated with this Package. 370 | 371 | 7. C or perl subroutines supplied by you and linked into this Package shall not 372 | be considered part of this Package. 373 | 374 | 8. The name of the Copyright Holder may not be used to endorse or promote 375 | products derived from this software without specific prior written permission. 376 | 377 | 9. THIS PACKAGE IS PROVIDED "AS IS" AND WITHOUT ANY EXPRESS OR IMPLIED 378 | WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED WARRANTIES OF 379 | MERCHANTIBILITY AND FITNESS FOR A PARTICULAR PURPOSE. 380 | 381 | The End 382 | -------------------------------------------------------------------------------- /MANIFEST.SKIP: -------------------------------------------------------------------------------- 1 | ^blib 2 | ^pm_to_blib 3 | .*\.old$ 4 | ^Makefile$ 5 | ^\.git 6 | .tar.gz$ 7 | .swp$ 8 | .un~$ 9 | MANIFEST.bak 10 | README.pod 11 | Debian_CPANTS.txt 12 | -------------------------------------------------------------------------------- /META.json: -------------------------------------------------------------------------------- 1 | { 2 | "abstract" : "Socket.IO PSGI application", 3 | "author" : [ 4 | "Viacheslav Tykhanovskyi, C." 5 | ], 6 | "dynamic_config" : 0, 7 | "generated_by" : "Minilla/v0.7.5, CPAN::Meta::Converter version 2.130880", 8 | "license" : [ 9 | "unknown" 10 | ], 11 | "meta-spec" : { 12 | "url" : "http://search.cpan.org/perldoc?CPAN::Meta::Spec", 13 | "version" : "2" 14 | }, 15 | "name" : "PocketIO", 16 | "no_index" : { 17 | "directory" : [ 18 | "t", 19 | "xt", 20 | "inc", 21 | "share", 22 | "eg", 23 | "examples", 24 | "author", 25 | "builder" 26 | ] 27 | }, 28 | "prereqs" : { 29 | "configure" : { 30 | "requires" : { 31 | "CPAN::Meta" : "0", 32 | "CPAN::Meta::Prereqs" : "0", 33 | "Module::Build" : "0.38" 34 | } 35 | }, 36 | "develop" : { 37 | "requires" : { 38 | "Test::CPAN::Meta" : "0", 39 | "Test::MinimumVersion" : "0.10108", 40 | "Test::Pod" : "1.41", 41 | "Test::Spellunker" : "v0.2.7" 42 | } 43 | }, 44 | "runtime" : { 45 | "requires" : { 46 | "AnyEvent" : "0", 47 | "Carp" : "0", 48 | "JSON" : "2.53", 49 | "Protocol::SocketIO" : "0.04", 50 | "Protocol::WebSocket" : "0.009006", 51 | "Scalar::Util" : "0", 52 | "Test::More" : "0", 53 | "Test::TCP" : "0" 54 | } 55 | } 56 | }, 57 | "release_status" : "unstable", 58 | "resources" : { 59 | "bugtracker" : { 60 | "web" : "https://github.com/vti/pocketio/issues" 61 | }, 62 | "homepage" : "https://github.com/vti/pocketio", 63 | "repository" : { 64 | "type" : "git", 65 | "url" : "git://github.com/vti/pocketio.git", 66 | "web" : "https://github.com/vti/pocketio" 67 | } 68 | }, 69 | "version" : "0.17", 70 | "x_contributors" : [ 71 | "Jens Gassmann ", 72 | "Audrey Tang ", 73 | "Uwe Voelker ", 74 | "Oskari Okko Ojala ", 75 | "Jason May ", 76 | "Michael FiG ", 77 | "Peter Stuifzand ", 78 | "tokubass ", 79 | "Mark Grimes ", 80 | "vti " 81 | ] 82 | } 83 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # NAME 2 | 3 | PocketIO - Socket.IO PSGI application 4 | 5 | # SYNOPSIS 6 | 7 | use Plack::Builder; 8 | 9 | builder { 10 | mount '/socket.io' => PocketIO->new( 11 | handler => sub { 12 | my $self = shift; 13 | 14 | $self->on( 15 | 'message' => sub { 16 | my $self = shift; 17 | my ($message) = @_; 18 | 19 | ...; 20 | } 21 | ); 22 | 23 | $self->send({buffer => []}); 24 | } 25 | ); 26 | 27 | $app; 28 | }; 29 | 30 | # or 31 | 32 | builder { 33 | mount '/socket.io' => 34 | PocketIO->new(class => 'MyApp::Handler', method => 'run'); 35 | 36 | $app; 37 | }; 38 | 39 | # DESCRIPTION 40 | 41 | [PocketIO](http://search.cpan.org/perldoc?PocketIO) is a server implementation of SocketIO in Perl, you still need 42 | `socket.io` javascript library on the client. 43 | 44 | [PocketIO](http://search.cpan.org/perldoc?PocketIO) aims to have API as close as possible to the Node.js implementation 45 | and sometimes it might look not very perlish. 46 | 47 | ## How to use 48 | 49 | First you mount [PocketIO](http://search.cpan.org/perldoc?PocketIO) as a normal [Plack](http://search.cpan.org/perldoc?Plack) application. It is recommended 50 | to mount it to the `/socket.io` path since that will not require any changes on 51 | the client side. 52 | 53 | When the client is connected your handler is called with a [PocketIO::Socket](http://search.cpan.org/perldoc?PocketIO::Socket) 54 | object as a first parameter. 55 | 56 | ## Sending and receiving messages 57 | 58 | A simple echo handler can look like this: 59 | 60 | sub { 61 | my $self = shift; 62 | 63 | $self->on('message' => sub { 64 | my $self = shift; 65 | my ($message) = @_; 66 | 67 | $self->send($message); 68 | }); 69 | } 70 | 71 | ## Sending and receiving events 72 | 73 | Events are special messages that behave like rpc calls. 74 | 75 | sub { 76 | my $self = shift; 77 | 78 | $self->on('username' => sub { 79 | my $self = shift; 80 | my ($nick) = @_; 81 | 82 | ... 83 | }); 84 | 85 | $self->emit('username', 'vti'); 86 | } 87 | 88 | ## Broadcasting and sending messages/events to everybody 89 | 90 | Broadcasting is sending messages to everybody except you: 91 | 92 | $self->broadcast->send('foo'); 93 | $self->broadcast->emit('foo'); 94 | 95 | Method `sockets` represents all connected clients: 96 | 97 | $self->sockets->send('foo'); 98 | $self->sockets->emit('foo'); 99 | 100 | ## Acknowlegements 101 | 102 | Sometimes you want to know when the client received a message or event. In order 103 | to achieve this just pass a callback as the last parameter: 104 | 105 | $self->send('foo', sub {'client got message'}); 106 | $self->emit('foo', sub {'client got event'}); 107 | 108 | ## Storing data in the socket object 109 | 110 | Often it is required to store some data in the client object. Instead of using 111 | global variables there are two handy methods: 112 | 113 | sub { 114 | my $self = shift; 115 | 116 | $self->set(foo => 'bar', sub { 'ready' }); 117 | $self->get('foo' => sub { 118 | my $self = shift; 119 | my ($err, $foo) = @_; 120 | }); 121 | } 122 | 123 | ## Namespacing 124 | 125 | Not implemented yet. 126 | 127 | ## Volatile messages 128 | 129 | Not implemented yet. 130 | 131 | ## Rooms 132 | 133 | A room is a named group of connections for more fine-grained 134 | broadcasts. You can subscribe or unsubscribe a socket to/from a room: 135 | 136 | sub { 137 | my $self = shift; 138 | 139 | $self->join('a room'); 140 | 141 | $self->sockets->in('a room')->emit('message', data); 142 | $self->broadcast->to('a room')->emit("other message"); 143 | } 144 | 145 | # CONFIGURATIONS 146 | 147 | - handler 148 | 149 | PocketIO->new( 150 | handler => sub { 151 | my $socket = shift; 152 | 153 | $socket->on( 154 | 'message' => sub { 155 | my $socket = shift; 156 | } 157 | ); 158 | 159 | $socket->send('hello'); 160 | } 161 | ); 162 | - class or instance, method 163 | 164 | PocketIO->new(class => 'MyHandler', method => 'run'); 165 | 166 | # or 167 | 168 | PocketIO->new(instance => MyHandler->new(foo => 'bar'), method => 'run'); 169 | 170 | package MyHandler; 171 | 172 | sub new { ... } # or use Moose, Boose, Goose, Doose 173 | 174 | sub run { 175 | my $self = shift; 176 | 177 | return sub { 178 | 179 | # same code as above 180 | } 181 | } 182 | 183 | Loads `class`, creates a new object or uses a passed `instance` and runs 184 | `run` method expecting it to return an anonymous subroutine. 185 | 186 | # TLS/SSL 187 | 188 | For TLS/SSL a secure proxy is needed. `stunnel` or [App::TLSMe](http://search.cpan.org/perldoc?App::TLSMe) are 189 | recommended. 190 | 191 | # SCALING 192 | 193 | See [PocketIO::Pool::Redis](http://search.cpan.org/perldoc?PocketIO::Pool::Redis). 194 | 195 | # DEBUGGING 196 | 197 | Use `POCKETIO_DEBUG` and `POCKETIO_CONNECTION_DEBUG` variables for debugging. 198 | 199 | # METHODS 200 | 201 | ## `new` 202 | 203 | Create a new [PocketIO](http://search.cpan.org/perldoc?PocketIO) instance. 204 | 205 | ## `pool` 206 | 207 | Holds [PocketIO::Pool](http://search.cpan.org/perldoc?PocketIO::Pool) object by default. 208 | 209 | ## `call` 210 | 211 | For Plack apps compatibility. 212 | 213 | ## `to_app` 214 | 215 | Returns PSGI code reference. 216 | 217 | # SEE ALSO 218 | 219 | More information about SocketIO you can find on the website [http://socket.io/](http://socket.io/), or 220 | on the GitHub [https://github.com/LearnBoost/Socket.IO](https://github.com/LearnBoost/Socket.IO). 221 | 222 | [Protocol::SocketIO](http://search.cpan.org/perldoc?Protocol::SocketIO), [PSGI](http://search.cpan.org/perldoc?PSGI) 223 | 224 | # DEVELOPMENT 225 | 226 | ## Repository 227 | 228 | http://github.com/vti/pocketio 229 | 230 | # CREDITS 231 | 232 | Socket.IO author(s) and contributors. 233 | 234 | Jens Gassmann 235 | 236 | Uwe Voelker 237 | 238 | Oskari Okko Ojala 239 | 240 | Jason May 241 | 242 | Michael FiG 243 | 244 | Peter Stuifzand 245 | 246 | tokubass 247 | 248 | mvgrimes 249 | 250 | # AUTHOR 251 | 252 | Viacheslav Tykhanovskyi, `vti@cpan.org`. 253 | 254 | # COPYRIGHT AND LICENSE 255 | 256 | Copyright (C) 2011-2013, Viacheslav Tykhanovskyi 257 | 258 | This program is free software, you can redistribute it and/or modify it under 259 | the terms of the Artistic License version 2.0. 260 | -------------------------------------------------------------------------------- /cpanfile: -------------------------------------------------------------------------------- 1 | requires 'Carp' => '0'; 2 | requires 'Scalar::Util' => '0'; 3 | 4 | requires 'AnyEvent' => '0'; 5 | requires 'JSON' => '2.53'; 6 | requires 'Protocol::SocketIO' => '0.04'; 7 | requires 'Protocol::WebSocket' => '0.009006'; 8 | 9 | requires 'Test::More' => '0'; 10 | requires 'Test::TCP' => '0'; 11 | -------------------------------------------------------------------------------- /examples/chat/README: -------------------------------------------------------------------------------- 1 | This is an example from Socket.IO-node distribution adapted for PocketIO. 2 | -------------------------------------------------------------------------------- /examples/chat/chat-redis.psgi: -------------------------------------------------------------------------------- 1 | my $root; 2 | 3 | BEGIN { 4 | use File::Basename (); 5 | use File::Spec (); 6 | 7 | $root = File::Basename::dirname(__FILE__); 8 | $root = File::Spec->rel2abs($root); 9 | 10 | unshift @INC, "$root/../../lib"; 11 | } 12 | 13 | use PocketIO; 14 | use PocketIO::Pool::Redis; 15 | 16 | use JSON; 17 | use Plack::App::File; 18 | use Plack::Builder; 19 | use Plack::Middleware::Static; 20 | 21 | my $nicknames = {}; 22 | 23 | builder { 24 | mount '/socket.io/socket.io.js' => 25 | Plack::App::File->new(file => "$root/public/socket.io.js"); 26 | 27 | mount '/socket.io/static/flashsocket/WebSocketMain.swf' => 28 | Plack::App::File->new(file => "$root/public/WebSocketMain.swf"); 29 | 30 | mount '/socket.io/static/flashsocket/WebSocketMainInsecure.swf' => 31 | Plack::App::File->new(file => "$root/public/WebSocketMainInsecure.swf"); 32 | 33 | mount '/socket.io' => PocketIO->new( 34 | pool => PocketIO::Pool::Redis->new, 35 | handler => sub { 36 | my $self = shift; 37 | 38 | $self->on( 39 | 'user message' => sub { 40 | my $self = shift; 41 | my ($message) = @_; 42 | 43 | $self->get( 44 | 'nick' => sub { 45 | my ($self, $err, $nick) = @_; 46 | 47 | $self->broadcast->emit('user message', $nick, 48 | $message); 49 | } 50 | ); 51 | } 52 | ); 53 | 54 | $self->on( 55 | 'nickname' => sub { 56 | my $self = shift; 57 | my ($nick, $cb) = @_; 58 | 59 | if ($nicknames->{$nick}) { 60 | $cb->(JSON::true); 61 | } 62 | else { 63 | $cb->(JSON::false); 64 | 65 | $self->set(nick => $nick); 66 | 67 | $nicknames->{$nick} = $nick; 68 | 69 | $self->broadcast->emit('announcement', 70 | $nick . ' connected'); 71 | $self->sockets->emit('nicknames', $nicknames); 72 | } 73 | } 74 | ); 75 | 76 | $self->on( 77 | 'disconnect' => sub { 78 | my $self = shift; 79 | 80 | $self->get( 81 | 'nick' => sub { 82 | my ($self, $err, $nick) = @_; 83 | 84 | delete $nicknames->{$nick}; 85 | 86 | $self->broadcast->emit('announcement', 87 | $nick . ' disconnected'); 88 | $self->broadcast->emit('nicknames', $nicknames); 89 | } 90 | ); 91 | } 92 | ); 93 | } 94 | ); 95 | 96 | mount '/' => builder { 97 | enable "Static", 98 | path => qr/\.(?:js|css|jpe?g|gif|png|html?|swf|ico)$/, 99 | root => "$root/public"; 100 | 101 | enable "SimpleLogger", level => 'debug'; 102 | 103 | my $html = do { 104 | local $/; 105 | open my $fh, '<', "$root/public/chat.html" 106 | or die $!; 107 | <$fh>; 108 | }; 109 | 110 | sub { 111 | [ 200, 112 | [ 'Content-Type' => 'text/html', 113 | 'Content-Length' => length($html) 114 | ], 115 | [$html] 116 | ]; 117 | }; 118 | }; 119 | }; 120 | -------------------------------------------------------------------------------- /examples/chat/chat-rooms.psgi: -------------------------------------------------------------------------------- 1 | my $root; 2 | 3 | BEGIN { 4 | use File::Basename (); 5 | use File::Spec (); 6 | 7 | $root = File::Basename::dirname(__FILE__); 8 | $root = File::Spec->rel2abs($root); 9 | 10 | unshift @INC, "$root/../../lib"; 11 | } 12 | 13 | use PocketIO; 14 | 15 | use JSON; 16 | use Plack::App::File; 17 | use Plack::Builder; 18 | use Plack::Middleware::Static; 19 | 20 | my $nicknames = {}; 21 | 22 | builder { 23 | mount '/socket.io/socket.io.js' => 24 | Plack::App::File->new(file => "$root/public/socket.io.js"); 25 | 26 | mount '/socket.io/static/flashsocket/WebSocketMain.swf' => 27 | Plack::App::File->new(file => "$root/public/WebSocketMain.swf"); 28 | 29 | mount '/socket.io/static/flashsocket/WebSocketMainInsecure.swf' => 30 | Plack::App::File->new(file => "$root/public/WebSocketMainInsecure.swf"); 31 | 32 | mount '/socket.io' => PocketIO->new( 33 | handler => sub { 34 | my $self = shift; 35 | 36 | $self->on( 37 | 'user message' => sub { 38 | my $self = shift; 39 | my ($message) = @_; 40 | 41 | $self->get('nick' => sub { 42 | my ($self, $err, $nick) = @_; 43 | 44 | if ($message =~ m{/join\s*(.*)}) { 45 | $self->join($1); 46 | $self->sockets->in($1)->emit('user message', $nick, 'Joined room'); 47 | } 48 | elsif ($message =~ m{/leave \s*(.*)}) { 49 | $self->leave($1); 50 | $self->sockets->in($1)->emit('user message', $nick, 'Left room'); 51 | } 52 | elsif ($message =~ m{/room\s*([^ ]+)\s*(.*)}) { 53 | $self->sockets->in($1)->emit('user message', $nick, "[$1]: $2"); 54 | } 55 | else { 56 | $self->broadcast->emit('user message', $nick, $message); 57 | } 58 | }); 59 | } 60 | ); 61 | 62 | $self->on( 63 | 'nickname' => sub { 64 | my $self = shift; 65 | my ($nick, $cb) = @_; 66 | 67 | if ($nicknames->{$nick}) { 68 | $cb->(JSON::true); 69 | } 70 | else { 71 | $cb->(JSON::false); 72 | 73 | $self->set(nick => $nick); 74 | 75 | $nicknames->{$nick} = $nick; 76 | 77 | $self->broadcast->emit('announcement', $nick . ' connected'); 78 | $self->sockets->emit('nicknames', $nicknames); 79 | } 80 | } 81 | ); 82 | 83 | $self->on( 84 | 'disconnect' => sub { 85 | my $self = shift; 86 | 87 | $self->get( 88 | 'nick' => sub { 89 | my ($self, $err, $nick) = @_; 90 | 91 | delete $nicknames->{$nick}; 92 | 93 | $self->broadcast->emit('announcement', 94 | $nick . ' disconnected'); 95 | $self->broadcast->emit('nicknames', $nicknames); 96 | } 97 | ); 98 | } 99 | ); 100 | } 101 | ); 102 | 103 | mount '/' => builder { 104 | enable "Static", 105 | path => qr/\.(?:js|css|jpe?g|gif|png|html?|swf|ico)$/, 106 | root => "$root/public"; 107 | 108 | enable "SimpleLogger", level => 'debug'; 109 | 110 | my $html = do { 111 | local $/; 112 | open my $fh, '<', "$root/public/chat.html" 113 | or die $!; 114 | <$fh>; 115 | }; 116 | 117 | sub { 118 | [ 200, 119 | [ 'Content-Type' => 'text/html', 120 | 'Content-Length' => length($html) 121 | ], 122 | [$html] 123 | ]; 124 | }; 125 | }; 126 | }; 127 | -------------------------------------------------------------------------------- /examples/chat/chat.psgi: -------------------------------------------------------------------------------- 1 | my $root; 2 | 3 | BEGIN { 4 | use File::Basename (); 5 | use File::Spec (); 6 | 7 | $root = File::Basename::dirname(__FILE__); 8 | $root = File::Spec->rel2abs($root); 9 | 10 | unshift @INC, "$root/../../lib"; 11 | } 12 | 13 | use PocketIO; 14 | 15 | use JSON; 16 | use Plack::App::File; 17 | use Plack::Builder; 18 | use Plack::Middleware::Static; 19 | 20 | my $nicknames = {}; 21 | 22 | builder { 23 | mount '/socket.io/socket.io.js' => 24 | Plack::App::File->new(file => "$root/public/socket.io.js"); 25 | 26 | mount '/socket.io/static/flashsocket/WebSocketMain.swf' => 27 | Plack::App::File->new(file => "$root/public/WebSocketMain.swf"); 28 | 29 | mount '/socket.io/static/flashsocket/WebSocketMainInsecure.swf' => 30 | Plack::App::File->new(file => "$root/public/WebSocketMainInsecure.swf"); 31 | 32 | mount '/socket.io' => PocketIO->new( 33 | handler => sub { 34 | my $self = shift; 35 | 36 | $self->on( 37 | 'user message' => sub { 38 | my $self = shift; 39 | my ($message) = @_; 40 | 41 | $self->get('nick' => sub { 42 | my ($self, $err, $nick) = @_; 43 | 44 | $self->broadcast->emit('user message', $nick, $message); 45 | }); 46 | } 47 | ); 48 | 49 | $self->on( 50 | 'nickname' => sub { 51 | my $self = shift; 52 | my ($nick, $cb) = @_; 53 | 54 | if ($nicknames->{$nick}) { 55 | $cb->(JSON::true); 56 | } 57 | else { 58 | $cb->(JSON::false); 59 | 60 | $self->set(nick => $nick); 61 | 62 | $nicknames->{$nick} = $nick; 63 | 64 | $self->broadcast->emit('announcement', $nick . ' connected'); 65 | $self->sockets->emit('nicknames', $nicknames); 66 | } 67 | } 68 | ); 69 | 70 | $self->on( 71 | 'disconnect' => sub { 72 | my $self = shift; 73 | 74 | $self->get( 75 | 'nick' => sub { 76 | my ($self, $err, $nick) = @_; 77 | 78 | delete $nicknames->{$nick}; 79 | 80 | $self->broadcast->emit('announcement', 81 | $nick . ' disconnected'); 82 | $self->broadcast->emit('nicknames', $nicknames); 83 | } 84 | ); 85 | } 86 | ); 87 | } 88 | ); 89 | 90 | mount '/' => builder { 91 | enable "Static", 92 | path => qr/\.(?:js|css|jpe?g|gif|png|html?|swf|ico)$/, 93 | root => "$root/public"; 94 | 95 | enable "SimpleLogger", level => 'debug'; 96 | 97 | my $html = do { 98 | local $/; 99 | open my $fh, '<', "$root/public/chat.html" 100 | or die $!; 101 | <$fh>; 102 | }; 103 | 104 | sub { 105 | [ 200, 106 | [ 'Content-Type' => 'text/html', 107 | 'Content-Length' => length($html) 108 | ], 109 | [$html] 110 | ]; 111 | }; 112 | }; 113 | }; 114 | -------------------------------------------------------------------------------- /examples/chat/public/WebSocketMain.swf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/vti/pocketio/64b7619ec29b280fc2e403e65129e629c0784436/examples/chat/public/WebSocketMain.swf -------------------------------------------------------------------------------- /examples/chat/public/WebSocketMainInsecure.swf: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/vti/pocketio/64b7619ec29b280fc2e403e65129e629c0784436/examples/chat/public/WebSocketMainInsecure.swf -------------------------------------------------------------------------------- /examples/chat/public/chat.html: -------------------------------------------------------------------------------- 1 |

Please type in your nickname and press enter.

Nickname already in use

Connecting to socket.io server
63 | -------------------------------------------------------------------------------- /examples/chat/public/stylesheets/style.css: -------------------------------------------------------------------------------- 1 | #chat, 2 | #nickname, 3 | #messages { 4 | width: 600px; 5 | } 6 | #chat { 7 | position: relative; 8 | border: 1px solid #ccc; 9 | } 10 | #nickname, 11 | #connecting { 12 | position: absolute; 13 | height: 410px; 14 | z-index: 100; 15 | left: 0; 16 | top: 0; 17 | background: #fff; 18 | text-align: center; 19 | width: 600px; 20 | font: 15px Georgia; 21 | color: #666; 22 | display: block; 23 | } 24 | #nickname .wrap, 25 | #connecting .wrap { 26 | padding-top: 150px; 27 | } 28 | #nickname input { 29 | border: 1px solid #ccc; 30 | padding: 10px; 31 | } 32 | #nickname input:focus { 33 | border-color: #999; 34 | outline: 0; 35 | } 36 | #nickname #nickname-err { 37 | color: #8b0000; 38 | font-size: 12px; 39 | visibility: hidden; 40 | } 41 | .connected #connecting { 42 | display: none; 43 | } 44 | .nickname-set #nickname { 45 | display: none; 46 | } 47 | #messages { 48 | height: 380px; 49 | background: #eee; 50 | } 51 | #messages em { 52 | text-shadow: 0 1px 0 #fff; 53 | color: #999; 54 | } 55 | #messages p { 56 | padding: 0; 57 | margin: 0; 58 | font: 12px Helvetica, Arial; 59 | padding: 5px 10px; 60 | } 61 | #messages p b { 62 | display: inline-block; 63 | padding-right: 10px; 64 | } 65 | #messages p:nth-child(even) { 66 | background: #fafafa; 67 | } 68 | #messages #nicknames { 69 | background: #ccc; 70 | padding: 2px 4px 4px; 71 | font: 11px Helvetica; 72 | } 73 | #messages #nicknames span { 74 | color: #000; 75 | } 76 | #messages #nicknames b { 77 | display: inline-block; 78 | color: #fff; 79 | background: #999; 80 | padding: 3px 6px; 81 | margin-right: 5px; 82 | -webkit-border-radius: 10px; 83 | -moz-border-radius: 10px; 84 | border-radius: 10px; 85 | text-shadow: 0 1px 0 #666; 86 | } 87 | #messages #lines { 88 | height: 355px; 89 | overflow: auto; 90 | overflow-x: hidden; 91 | overflow-y: auto; 92 | } 93 | #messages #lines::-webkit-scrollbar { 94 | width: 6px; 95 | height: 6px; 96 | } 97 | #messages #lines::-webkit-scrollbar-button:start:decrement, 98 | #messages #lines ::-webkit-scrollbar-button:end:increment { 99 | display: block; 100 | height: 10px; 101 | } 102 | #messages #lines::-webkit-scrollbar-button:vertical:increment { 103 | background-color: #fff; 104 | } 105 | #messages #lines::-webkit-scrollbar-track-piece { 106 | background-color: #fff; 107 | -webkit-border-radius: 3px; 108 | } 109 | #messages #lines::-webkit-scrollbar-thumb:vertical { 110 | height: 50px; 111 | background-color: #ccc; 112 | -webkit-border-radius: 3px; 113 | } 114 | #messages #lines::-webkit-scrollbar-thumb:horizontal { 115 | width: 50px; 116 | background-color: #fff; 117 | -webkit-border-radius: 3px; 118 | } 119 | #send-message { 120 | background: #fff; 121 | position: relative; 122 | } 123 | #send-message input { 124 | border: none; 125 | height: 30px; 126 | padding: 0 10px; 127 | line-height: 30px; 128 | vertical-align: middle; 129 | width: 580px; 130 | } 131 | #send-message input:focus { 132 | outline: 0; 133 | } 134 | #send-message button { 135 | position: absolute; 136 | top: 5px; 137 | right: 5px; 138 | } 139 | button { 140 | margin: 0; 141 | -webkit-user-select: none; 142 | -moz-user-select: none; 143 | user-select: none; 144 | display: inline-block; 145 | text-decoration: none; 146 | background: #43a1f7; 147 | background: -webkit-gradient(linear, left top, left bottom, color-stop(0, #43a1f7), color-stop(1, #377ad0)); 148 | background: -webkit-linear-gradient(top, #43a1f7 0%, #377ad0 100%); 149 | background: -moz-linear-gradient(top, #43a1f7 0%, #377ad0 100%); 150 | background: linear-gradient(top, #43a1f7 0%, #377ad0 100%); 151 | border: 1px solid #2e70c4; 152 | -webkit-border-radius: 16px; 153 | -moz-border-radius: 16px; 154 | border-radius: 16px; 155 | color: #fff; 156 | font-family: "lucida grande", sans-serif; 157 | font-size: 11px; 158 | font-weight: normal; 159 | line-height: 1; 160 | padding: 3px 10px 5px 10px; 161 | text-align: center; 162 | text-shadow: 0 -1px 1px #2d6dc0; 163 | } 164 | button:hover, 165 | button.hover { 166 | background: darker; 167 | background: -webkit-gradient(linear, left top, left bottom, color-stop(0, #43a1f7), color-stop(1, #2e70c4)); 168 | background: -webkit-linear-gradient(top, #43a1f7 0%, #2e70c4 100%); 169 | background: -moz-linear-gradient(top, #43a1f7 0%, #2e70c4 100%); 170 | background: linear-gradient(top, #43a1f7 0%, #2e70c4 100%); 171 | border: 1px solid #2e70c4; 172 | cursor: pointer; 173 | text-shadow: 0 -1px 1px #2c6bbb; 174 | } 175 | button:active, 176 | button.active { 177 | background: #2e70c4; 178 | border: 1px solid #2e70c4; 179 | border-bottom: 1px solid #2861aa; 180 | text-shadow: 0 -1px 1px #2b67b5; 181 | } 182 | button:focus, 183 | button.focus { 184 | outline: none; 185 | -webkit-box-shadow: 0 1px 0 0 rgba(255,255,255,0.4), 0 0 4px 0 #377ad0; 186 | -moz-box-shadow: 0 1px 0 0 rgba(255,255,255,0.4), 0 0 4px 0 #377ad0; 187 | box-shadow: 0 1px 0 0 rgba(255,255,255,0.4), 0 0 4px 0 #377ad0; 188 | } 189 | -------------------------------------------------------------------------------- /examples/flash-policy-server: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env perl 2 | 3 | use strict; 4 | use warnings; 5 | 6 | use AnyEvent; 7 | use AnyEvent::Socket; 8 | use AnyEvent::Handle; 9 | use Getopt::Long; 10 | 11 | die 'Must be run by root' unless $> == 0 && $< == 0; 12 | 13 | my $domain = "localhost"; 14 | my $daemonize; 15 | my $secure; 16 | 17 | GetOptions( 18 | 'daemonize' => \$daemonize, 19 | 'domain=s' => \$domain, 20 | 'secure' => \$secure 21 | ) or die "Usage:\n"; 22 | 23 | my $cv = AnyEvent->condvar; 24 | 25 | tcp_server undef, 843, sub { 26 | my ($fh, $host, $port) = @_; 27 | 28 | my $handle = AnyEvent::Handle->new(fh => $fh); 29 | 30 | my $response = <<"EOF"; 31 | 32 | 33 | 34 | 35 | 36 | 37 | EOF 38 | 39 | $handle->push_write($response); 40 | }; 41 | 42 | $cv->recv; 43 | -------------------------------------------------------------------------------- /lib/PocketIO.pm: -------------------------------------------------------------------------------- 1 | package PocketIO; 2 | 3 | use strict; 4 | use warnings; 5 | 6 | our $VERSION = '0.17'; 7 | 8 | use overload '&{}' => sub { shift->to_app(@_) }, fallback => 1; 9 | 10 | use PocketIO::Exception; 11 | use PocketIO::Resource; 12 | use PocketIO::Pool; 13 | 14 | sub new { 15 | my $class = shift; 16 | 17 | my $self = {@_}; 18 | bless $self, $class; 19 | 20 | $self->{handler} = $self->_get_handler; 21 | 22 | $self->{socketio} ||= {}; 23 | 24 | return $self; 25 | } 26 | 27 | sub to_app { 28 | my $self = shift; 29 | 30 | return sub { $self->call(@_) }; 31 | } 32 | 33 | sub call { 34 | my $self = shift; 35 | my ($env) = @_; 36 | 37 | my $response; 38 | eval { 39 | my $dispatcher = $self->_build_dispatcher(%{$self->{socketio}}); 40 | 41 | $response = $dispatcher->dispatch($env, $self->{handler}); 42 | } or do { 43 | my $e = $@; 44 | 45 | require Scalar::Util; 46 | die $e unless Scalar::Util::blessed($e); 47 | 48 | my $code = $e->code; 49 | my $message = $e->message || 'Internal Server Error'; 50 | 51 | my @headers = ( 52 | 'Content-Type' => 'text/plain', 53 | 'Content-Length' => length($message), 54 | ); 55 | 56 | $response = [$code, \@headers, [$message]]; 57 | }; 58 | 59 | return $response; 60 | } 61 | 62 | sub pool { 63 | my $self = shift; 64 | 65 | $self->{pool} ||= PocketIO::Pool->new; 66 | 67 | return $self->{pool}; 68 | } 69 | 70 | sub _build_dispatcher { 71 | my $self = shift; 72 | 73 | return PocketIO::Resource->new(pool => $self->pool, @_); 74 | } 75 | 76 | sub _get_handler { 77 | my $self = shift; 78 | 79 | return $self->{handler} if $self->{handler}; 80 | 81 | die q{Either 'handler', 'class' or 'instance' must be specified} 82 | unless $self->{instance} || $self->{class}; 83 | 84 | my $method = $self->{method} || 'run'; 85 | 86 | my $instance = $self->{instance} 87 | || do { 88 | my $class = $self->{class}; 89 | 90 | my $path = $class; 91 | $path =~ s{::}{/}g; 92 | $path .= '.pm'; 93 | 94 | require $path; 95 | $class->new; 96 | }; 97 | 98 | return $instance->$method; 99 | } 100 | 101 | 1; 102 | __END__ 103 | 104 | =head1 NAME 105 | 106 | PocketIO - Socket.IO PSGI application 107 | 108 | =head1 SYNOPSIS 109 | 110 | use Plack::Builder; 111 | 112 | builder { 113 | mount '/socket.io' => PocketIO->new( 114 | handler => sub { 115 | my $self = shift; 116 | 117 | $self->on( 118 | 'message' => sub { 119 | my $self = shift; 120 | my ($message) = @_; 121 | 122 | ...; 123 | } 124 | ); 125 | 126 | $self->send({buffer => []}); 127 | } 128 | ); 129 | 130 | $app; 131 | }; 132 | 133 | # or 134 | 135 | builder { 136 | mount '/socket.io' => 137 | PocketIO->new(class => 'MyApp::Handler', method => 'run'); 138 | 139 | $app; 140 | }; 141 | 142 | =head1 DESCRIPTION 143 | 144 | L is a server implementation of SocketIO in Perl, you still need 145 | C javascript library for the client (available at 146 | L). 147 | 148 | L aims to have API as close as possible to the Node.js implementation 149 | and sometimes it might look not very perlish. 150 | 151 | Currently only the pre-v1 releases of SocketIO are supported by this module. Client 152 | libraries for the v1.* and v2.* won't work with the server. 153 | 154 | =head2 How to use 155 | 156 | First you mount L as a normal L application. It is recommended 157 | to mount it to the C path since that will not require any changes on 158 | the client side. 159 | 160 | When the client is connected your handler is called with a L 161 | object as a first parameter. 162 | 163 | =head2 Sending and receiving messages 164 | 165 | A simple echo handler can look like this: 166 | 167 | sub { 168 | my $self = shift; 169 | 170 | $self->on('message' => sub { 171 | my $self = shift; 172 | my ($message) = @_; 173 | 174 | $self->send($message); 175 | }); 176 | } 177 | 178 | =head2 Sending and receiving events 179 | 180 | Events are special messages that behave like rpc calls. 181 | 182 | sub { 183 | my $self = shift; 184 | 185 | $self->on('username' => sub { 186 | my $self = shift; 187 | my ($nick) = @_; 188 | 189 | ... 190 | }); 191 | 192 | $self->emit('username', 'vti'); 193 | } 194 | 195 | =head2 Broadcasting and sending messages/events to everybody 196 | 197 | Broadcasting is sending messages to everybody except you: 198 | 199 | $self->broadcast->send('foo'); 200 | $self->broadcast->emit('foo'); 201 | 202 | Method C represents all connected clients: 203 | 204 | $self->sockets->send('foo'); 205 | $self->sockets->emit('foo'); 206 | 207 | =head2 Acknowlegements 208 | 209 | Sometimes you want to know when the client received a message or event. In order 210 | to achieve this just pass a callback as the last parameter: 211 | 212 | $self->send('foo', sub {'client got message'}); 213 | $self->emit('foo', sub {'client got event'}); 214 | 215 | =head2 Storing data in the socket object 216 | 217 | Often it is required to store some data in the client object. Instead of using 218 | global variables there are two handy methods: 219 | 220 | sub { 221 | my $self = shift; 222 | 223 | $self->set(foo => 'bar', sub { 'ready' }); 224 | $self->get('foo' => sub { 225 | my $self = shift; 226 | my ($err, $foo) = @_; 227 | }); 228 | } 229 | 230 | =head2 Namespacing 231 | 232 | Not implemented yet. 233 | 234 | =head2 Volatile messages 235 | 236 | Not implemented yet. 237 | 238 | =head2 Rooms 239 | 240 | A room is a named group of connections for more fine-grained 241 | broadcasts. You can subscribe or unsubscribe a socket to/from a room: 242 | 243 | sub { 244 | my $self = shift; 245 | 246 | $self->join('a room'); 247 | 248 | $self->sockets->in('a room')->emit('message', data); 249 | $self->broadcast->to('a room')->emit("other message"); 250 | } 251 | 252 | =head1 CONFIGURATIONS 253 | 254 | =over 4 255 | 256 | =item handler 257 | 258 | PocketIO->new( 259 | handler => sub { 260 | my $socket = shift; 261 | 262 | $socket->on( 263 | 'message' => sub { 264 | my $socket = shift; 265 | } 266 | ); 267 | 268 | $socket->send('hello'); 269 | } 270 | ); 271 | 272 | =item class or instance, method 273 | 274 | PocketIO->new(class => 'MyHandler', method => 'run'); 275 | 276 | # or 277 | 278 | PocketIO->new(instance => MyHandler->new(foo => 'bar'), method => 'run'); 279 | 280 | package MyHandler; 281 | 282 | sub new { ... } # or use Moose, Boose, Goose, Doose 283 | 284 | sub run { 285 | my $self = shift; 286 | 287 | return sub { 288 | 289 | # same code as above 290 | } 291 | } 292 | 293 | Loads C, creates a new object or uses a passed C and runs 294 | C method expecting it to return an anonymous subroutine. 295 | 296 | =back 297 | 298 | =head1 TLS/SSL 299 | 300 | For TLS/SSL a secure proxy is needed. C or L are 301 | recommended. 302 | 303 | =head1 SCALING 304 | 305 | See L. 306 | 307 | =head1 DEBUGGING 308 | 309 | Use C and C variables for debugging. 310 | 311 | =head1 METHODS 312 | 313 | =head2 C 314 | 315 | Create a new L instance. 316 | 317 | =head2 C 318 | 319 | Holds L object by default. 320 | 321 | =head2 C 322 | 323 | For Plack apps compatibility. 324 | 325 | =head2 C 326 | 327 | Returns PSGI code reference. 328 | 329 | =head1 SEE ALSO 330 | 331 | More information about SocketIO you can find on the website L, or 332 | on the GitHub L. 333 | 334 | L, L 335 | 336 | =head1 DEVELOPMENT 337 | 338 | =head2 Repository 339 | 340 | http://github.com/vti/pocketio 341 | 342 | =head1 CREDITS 343 | 344 | Socket.IO author(s) and contributors. 345 | 346 | Jens Gassmann 347 | 348 | Uwe Voelker 349 | 350 | Oskari Okko Ojala 351 | 352 | Jason May 353 | 354 | Michael FiG 355 | 356 | Peter Stuifzand 357 | 358 | tokubass 359 | 360 | mvgrimes 361 | 362 | =head1 AUTHOR 363 | 364 | Viacheslav Tykhanovskyi, C. 365 | 366 | =head1 COPYRIGHT AND LICENSE 367 | 368 | Copyright (C) 2011-2013, Viacheslav Tykhanovskyi 369 | 370 | This program is free software, you can redistribute it and/or modify it under 371 | the terms of the Artistic License version 2.0. 372 | 373 | =cut 374 | -------------------------------------------------------------------------------- /lib/PocketIO/Broadcast.pm: -------------------------------------------------------------------------------- 1 | package PocketIO::Broadcast; 2 | 3 | use strict; 4 | use warnings; 5 | 6 | use base 'PocketIO::Sockets'; 7 | 8 | use PocketIO::Room; 9 | 10 | sub send { 11 | my $self = shift; 12 | 13 | $self->{pool}->broadcast($self->{conn}, @_); 14 | 15 | return $self; 16 | } 17 | 18 | sub emit { 19 | my $self = shift; 20 | my $name = shift; 21 | 22 | my $event = $self->_build_event_message($name, @_); 23 | 24 | $self->{pool}->broadcast($self->{conn}, $event); 25 | 26 | return $self; 27 | } 28 | 29 | 30 | sub to { 31 | my $self = shift; 32 | my ($room) = @_; 33 | 34 | return PocketIO::Room->new( 35 | room => $room, 36 | conn => $self->{conn}, 37 | pool => $self->{pool} 38 | ); 39 | } 40 | 41 | 1; 42 | __END__ 43 | 44 | =head1 NAME 45 | 46 | PocketIO::Sockets - Sockets class 47 | 48 | =head1 DESCRIPTION 49 | 50 | Used to send broadcast messages (to everybody except self). 51 | 52 | =head1 METHODS 53 | 54 | =head2 C 55 | 56 | Create new instance. 57 | 58 | =head2 C 59 | 60 | Send message. 61 | 62 | =head2 C 63 | 64 | Emit event. 65 | 66 | =head2 C 67 | 68 | Only broadcast to a specific room. 69 | 70 | =cut 71 | -------------------------------------------------------------------------------- /lib/PocketIO/Connection.pm: -------------------------------------------------------------------------------- 1 | package PocketIO::Connection; 2 | 3 | use strict; 4 | use warnings; 5 | 6 | use AnyEvent; 7 | use Scalar::Util qw(blessed); 8 | 9 | use PocketIO::Message; 10 | use PocketIO::Socket; 11 | use PocketIO::Sockets; 12 | use PocketIO::Broadcast; 13 | 14 | use constant DEBUG => $ENV{POCKETIO_CONNECTION_DEBUG}; 15 | 16 | sub new { 17 | my $class = shift; 18 | 19 | my $self = {@_}; 20 | bless $self, $class; 21 | 22 | $self->{connect_timeout} ||= 30; 23 | $self->{reconnect_timeout} ||= 15; 24 | $self->{close_timeout} ||= 15; 25 | 26 | $self->{on_connect_timeout} = sub { $_[0]->emit('connect_failed') }; 27 | $self->{on_reconnect_timeout} = sub { $_[0]->emit('reconnect_failed') }; 28 | $self->{on_close_timeout} = sub { $_[0]->close }; 29 | 30 | $self->{max_messages_to_stage} ||= 32; 31 | $self->{messages} = []; 32 | 33 | $self->{on_connect_failed} ||= sub { }; 34 | $self->{on_reconnect} ||= sub { }; 35 | $self->{on_reconnect_failed} ||= sub { }; 36 | $self->{on_message} ||= sub { }; 37 | $self->{on_disconnect} ||= sub { }; 38 | $self->{on_error} ||= sub { }; 39 | $self->{on_close} ||= sub { }; 40 | 41 | $self->{socket} ||= $self->_build_socket; 42 | my $on_connect = delete $self->{on_connect} || sub { }; 43 | $self->{on_connect} = sub { 44 | my $self = shift; 45 | 46 | eval { 47 | $on_connect->($self->{socket}, @{$self->{on_connect_args} || []}); 48 | 1; 49 | } || do { 50 | warn "Connection error: $_"; 51 | 52 | $self->close; 53 | }; 54 | }; 55 | 56 | DEBUG && $self->_debug('Connection created'); 57 | 58 | $self->connecting; 59 | 60 | return $self; 61 | } 62 | 63 | sub new_passive { 64 | my $class = shift; 65 | my $self = {@_}; 66 | bless $self, $class; 67 | return $self; 68 | } 69 | 70 | sub socket { $_[0]->{socket} } 71 | 72 | sub pool { $_[0]->{pool} } 73 | 74 | sub type { @_ > 1 ? $_[0]->{type} = $_[1] : $_[0]->{type} } 75 | 76 | sub is_connected { $_[0]->{is_connected} } 77 | 78 | sub connecting { 79 | my $self = shift; 80 | 81 | DEBUG && $self->_debug("State 'connecting'"); 82 | 83 | $self->_start_timer('connect'); 84 | } 85 | 86 | sub reconnecting { 87 | my $self = shift; 88 | 89 | DEBUG && $self->_debug("State 'reconnecting'"); 90 | 91 | $self->_stop_timer('close'); 92 | 93 | $self->_start_timer('reconnect'); 94 | } 95 | 96 | sub connected { 97 | my $self = shift; 98 | 99 | DEBUG && $self->_debug("State 'connected'"); 100 | 101 | $self->_stop_timer('connect'); 102 | 103 | $self->{is_connected} = 1; 104 | 105 | my $message = PocketIO::Message->new(type => 'connect'); 106 | $self->write($message); 107 | 108 | $self->_start_timer('close'); 109 | 110 | $self->emit('connect'); 111 | 112 | return $self; 113 | } 114 | 115 | sub reconnected { 116 | my $self = shift; 117 | 118 | DEBUG && $self->_debug("State 'reconnected'"); 119 | 120 | $self->_stop_timer('reconnect'); 121 | 122 | $self->emit('reconnect'); 123 | 124 | $self->_start_timer('close'); 125 | 126 | return $self; 127 | } 128 | 129 | sub disconnected { 130 | my $self = shift; 131 | 132 | DEBUG && $self->_debug("State 'disconnected'"); 133 | 134 | $self->_stop_timer('connect'); 135 | $self->_stop_timer('reconnect'); 136 | $self->_stop_timer('close'); 137 | 138 | $self->{data} = ''; 139 | $self->{messages} = []; 140 | 141 | $self->{is_connected} = 0; 142 | 143 | $self->{disconnect_timer} = AnyEvent->timer( 144 | after => 0, 145 | cb => sub { 146 | return unless $self; 147 | 148 | if ($self->{socket}) { 149 | if (my $cb = $self->{socket}->on('disconnect')) { 150 | $cb->($self->{socket}); 151 | } 152 | undef $self->{socket}; 153 | } 154 | 155 | undef $self; 156 | } 157 | ); 158 | 159 | return $self; 160 | } 161 | 162 | sub close { 163 | my $self = shift; 164 | 165 | my $message = PocketIO::Message->new(type => 'disconnect'); 166 | $self->write($message); 167 | 168 | $self->emit('close'); 169 | 170 | #$self->disconnected; 171 | 172 | return $self; 173 | } 174 | 175 | sub id { 176 | my $self = shift; 177 | 178 | $self->{id} ||= $self->_generate_id; 179 | 180 | return $self->{id}; 181 | } 182 | 183 | sub on { 184 | my $self = shift; 185 | my $event = shift; 186 | 187 | my $name = "on_$event"; 188 | 189 | unless (@_) { 190 | DEBUG && $self->_debug("Event 'on_$event'"); 191 | 192 | return $self->{$name}; 193 | } 194 | 195 | $self->{$name} = $_[0]; 196 | 197 | return $self; 198 | } 199 | 200 | sub emit { 201 | my $self = shift; 202 | my $event = shift; 203 | 204 | $event = "on_$event"; 205 | 206 | return unless exists $self->{$event}; 207 | 208 | DEBUG && $self->_debug("Emitting '$event'"); 209 | 210 | $self->{$event}->($self, @_); 211 | 212 | return $self; 213 | } 214 | 215 | sub stage_message { 216 | my $self = shift; 217 | my ($message) = @_; 218 | 219 | return if @{$self->{messages}} >= $self->{max_messages_to_stage}; 220 | 221 | push @{$self->{messages}}, $message; 222 | 223 | return $self; 224 | } 225 | 226 | sub has_staged_messages { 227 | my $self = shift; 228 | 229 | return @{$self->{messages}} > 0; 230 | } 231 | 232 | sub staged_message { 233 | my $self = shift; 234 | 235 | return shift @{$self->{messages}}; 236 | } 237 | 238 | sub send_heartbeat { 239 | my $self = shift; 240 | 241 | $self->{heartbeat}++; 242 | 243 | DEBUG && $self->_debug('Send heartbeat'); 244 | 245 | my $message = PocketIO::Message->new(type => 'heartbeat'); 246 | 247 | return $self->write($message); 248 | } 249 | 250 | sub send { 251 | my $self = shift; 252 | my ($message) = @_; 253 | 254 | $message = $self->_build_message($message); 255 | 256 | $self->write($message); 257 | 258 | return $self; 259 | } 260 | 261 | sub broadcast { 262 | my $self = shift; 263 | 264 | return PocketIO::Broadcast->new(conn => $self, pool => $self->pool); 265 | } 266 | 267 | sub sockets { 268 | my $self = shift; 269 | 270 | return PocketIO::Sockets->new(pool => $self->pool); 271 | } 272 | 273 | sub parse_message { 274 | my $self = shift; 275 | my ($message) = @_; 276 | 277 | DEBUG && $self->_debug("Received '" . substr($message, 0, 80) . "'"); 278 | 279 | $message = PocketIO::Message->new->parse($message); 280 | return unless $message; 281 | 282 | $self->_stop_timer('close'); 283 | 284 | if ($message->is_message) { 285 | $self->{socket}->on('message')->($self->{socket}, $message->data); 286 | } 287 | elsif ($message->type eq 'event') { 288 | my $name = $message->data->{name}; 289 | my $args = $message->data->{args}; 290 | 291 | my $id = $message->id; 292 | 293 | $self->{socket}->on($name)->( 294 | $self->{socket}, 295 | @$args => sub { 296 | my $message = PocketIO::Message->new( 297 | type => 'ack', 298 | message_id => $id, 299 | args => [@_] 300 | ); 301 | 302 | $self->write($message); 303 | } 304 | ) if defined $self->{socket}->on($name); 305 | } 306 | elsif ($message->type eq 'heartbeat') { 307 | 308 | # TODO 309 | } 310 | else { 311 | 312 | # TODO 313 | } 314 | 315 | $self->_start_timer('close'); 316 | 317 | return $self; 318 | } 319 | 320 | sub write { 321 | my $self = shift; 322 | my ($bytes) = @_; 323 | 324 | $self->_restart_timer('close'); 325 | 326 | $bytes = $bytes->to_bytes if blessed $bytes; 327 | 328 | if ($self->{on_write}) { 329 | DEBUG && $self->_debug("Writing '" . substr($bytes, 0, 50) . "'"); 330 | $self->emit('write', $bytes); 331 | } 332 | else { 333 | DEBUG && $self->_debug("Staging '" . substr($bytes, 0, 50) . "'"); 334 | $self->stage_message($bytes); 335 | } 336 | } 337 | 338 | sub _start_timer { 339 | my $self = shift; 340 | my ($timer) = @_; 341 | 342 | my $timeout = $self->{"${timer}_timeout"}; 343 | return if (!defined $timeout); 344 | 345 | DEBUG && $self->_debug("Start '${timer}_timer' ($timeout)"); 346 | 347 | $self->{"${timer}_timer"} = AnyEvent->timer( 348 | after => $timeout, 349 | cb => sub { 350 | DEBUG && $self->_debug("Timeout '${timer}_timeout'"); 351 | 352 | $self->{"on_${timer}_timeout"}->($self); 353 | } 354 | ); 355 | } 356 | 357 | sub _stop_timer { 358 | my $self = shift; 359 | my ($timer) = @_; 360 | 361 | DEBUG && $self->_debug("Stop '${timer}_timer'"); 362 | 363 | delete $self->{"${timer}_timer"}; 364 | } 365 | 366 | sub _restart_timer { 367 | my $self = shift; 368 | my ($timer) = @_; 369 | 370 | $self->_stop_timer($timer); 371 | $self->_start_timer($timer); 372 | } 373 | 374 | sub _build_message { 375 | my $self = shift; 376 | my ($message) = @_; 377 | 378 | return $message if blessed $message; 379 | 380 | return PocketIO::Message->new(data => $message); 381 | } 382 | 383 | sub _generate_id { 384 | my $self = shift; 385 | 386 | my $string = ''; 387 | 388 | for (1 .. 16) { 389 | $string .= int(rand(10)); 390 | } 391 | 392 | return $string; 393 | } 394 | 395 | sub _debug { 396 | my $self = shift; 397 | my ($message) = @_; 398 | 399 | warn time . ' (' . $self->id . '): ' . $message . "\n"; 400 | } 401 | 402 | sub _build_socket { 403 | my $self = shift; 404 | 405 | return PocketIO::Socket->new(conn => $self); 406 | } 407 | 408 | 1; 409 | __END__ 410 | 411 | =head1 NAME 412 | 413 | PocketIO::Connection - Connection class 414 | 415 | =head1 DESCRIPTION 416 | 417 | L is a connection class that 418 | encapsulates all the logic for bulding and parsing Socket.IO messages. Used 419 | internally. 420 | 421 | =head1 METHODS 422 | 423 | =head2 C 424 | 425 | =head2 C 426 | 427 | =head2 C 428 | 429 | =head2 C 430 | 431 | =head2 C 432 | 433 | =head2 C 434 | 435 | =head2 C 436 | 437 | =head2 C 438 | 439 | =head2 C 440 | 441 | =head2 C 442 | 443 | =head2 C 444 | 445 | =head2 C 446 | 447 | =head2 C 448 | 449 | =head2 C 450 | 451 | =head2 C 452 | 453 | =head2 C 454 | 455 | =head2 C 456 | 457 | =head2 C 458 | 459 | =head2 C 460 | 461 | =head2 C 462 | 463 | =head2 C 464 | 465 | =head2 C 466 | 467 | =head2 C 468 | 469 | =cut 470 | -------------------------------------------------------------------------------- /lib/PocketIO/Exception.pm: -------------------------------------------------------------------------------- 1 | package PocketIO::Exception; 2 | 3 | use strict; 4 | use warnings; 5 | 6 | use overload '""' => sub { $_[0]->to_string }, fallback => 1; 7 | 8 | require Carp; 9 | 10 | sub new { 11 | my $class = shift; 12 | 13 | my $self = bless {@_}, $class; 14 | 15 | $self->{code} ||= 500; 16 | 17 | return $self; 18 | } 19 | 20 | sub code { $_[0]->{code} } 21 | sub message { $_[0]->{message} } 22 | 23 | sub throw { 24 | my $class = shift; 25 | my ($code, $message) = @_; 26 | 27 | $message = '' unless defined $message; 28 | 29 | Carp::croak($class->new(code => $code, message => $message)); 30 | } 31 | 32 | *as_string = \&to_string; 33 | sub to_string { $_[0]->message } 34 | 35 | 1; 36 | -------------------------------------------------------------------------------- /lib/PocketIO/Handle.pm: -------------------------------------------------------------------------------- 1 | package PocketIO::Handle; 2 | 3 | use strict; 4 | use warnings; 5 | 6 | use AnyEvent::Handle; 7 | 8 | use constant DEBUG => $ENV{POCKETIO_HANDLE_DEBUG}; 9 | 10 | sub new { 11 | my $class = shift; 12 | my (%params) = @_; 13 | 14 | my $fh = delete $params{fh}; 15 | 16 | my $self = {handle => AnyEvent::Handle->new(fh => $fh), %params}; 17 | bless $self, $class; 18 | 19 | $self->{heartbeat_timeout} ||= 10; 20 | 21 | $fh->autoflush; 22 | 23 | $self->{handle}->no_delay(1); 24 | $self->{handle}->on_eof(sub { warn "Unhandled handle eof" }); 25 | $self->{handle}->on_error(sub { warn "Unhandled handle error: $_[2]" }); 26 | 27 | # This is needed for the correct EOF handling 28 | $self->{handle}->on_read(sub { }); 29 | 30 | return $self; 31 | } 32 | 33 | sub fh { $_[0]->{handle}->fh } 34 | 35 | sub on_heartbeat { 36 | my $self = shift; 37 | my ($cb) = @_; 38 | 39 | $self->{handle}->wtimeout($self->{heartbeat_timeout}); 40 | $self->{handle}->on_wtimeout($cb); 41 | 42 | return $self; 43 | } 44 | 45 | sub on_read { 46 | my $self = shift; 47 | my ($cb) = @_; 48 | 49 | $self->{handle}->on_read( 50 | sub { 51 | my $handle = shift; 52 | 53 | $handle->push_read( 54 | sub { 55 | $cb->($self, $_[0]->rbuf); 56 | } 57 | ); 58 | } 59 | ); 60 | 61 | return $self; 62 | } 63 | 64 | sub on_eof { 65 | my $self = shift; 66 | my ($cb) = @_; 67 | 68 | $self->{handle}->on_eof( 69 | sub { 70 | $cb->($self); 71 | } 72 | ); 73 | 74 | return $self; 75 | } 76 | 77 | sub on_error { 78 | my $self = shift; 79 | my ($cb) = @_; 80 | 81 | $self->{handle}->on_error( 82 | sub { 83 | $cb->($self); 84 | } 85 | ); 86 | 87 | return $self; 88 | } 89 | 90 | sub write { 91 | my $self = shift; 92 | my ($chunk, $cb) = @_; 93 | 94 | my $handle = $self->{handle}; 95 | return $self unless $handle && $handle->fh; 96 | 97 | $handle->push_write($chunk); 98 | 99 | if ($cb) { 100 | $handle->on_drain( 101 | sub { 102 | my $handle = shift; 103 | 104 | $handle->on_drain(undef); 105 | 106 | $cb->($self); 107 | } 108 | ); 109 | } 110 | 111 | return $self; 112 | } 113 | 114 | sub close { 115 | my $self = shift; 116 | 117 | my $handle = delete $self->{handle}; 118 | return $self unless $handle; 119 | 120 | $handle->wtimeout(0); 121 | 122 | $handle->on_drain; 123 | $handle->on_error; 124 | 125 | $handle->on_drain( 126 | sub { 127 | if ($_[0]->fh) { 128 | shutdown $_[0]->fh, 1; 129 | close $handle->fh; 130 | } 131 | 132 | $_[0]->destroy; 133 | undef $handle; 134 | } 135 | ); 136 | 137 | return $self; 138 | } 139 | 140 | 1; 141 | __END__ 142 | 143 | =head1 NAME 144 | 145 | PocketIO::Handle - Handle 146 | 147 | =head1 DESCRIPTION 148 | 149 | L is a wrapper on top of 150 | L. 151 | 152 | =head1 METHODS 153 | 154 | =head2 C 155 | 156 | =head2 C 157 | 158 | =head2 C 159 | 160 | =head2 C 161 | 162 | =head2 C 163 | 164 | =head2 C 165 | 166 | =head2 C 167 | 168 | =head2 C 169 | 170 | =head1 SEE ALSO 171 | 172 | L 173 | 174 | =cut 175 | -------------------------------------------------------------------------------- /lib/PocketIO/Message.pm: -------------------------------------------------------------------------------- 1 | package PocketIO::Message; 2 | 3 | use strict; 4 | use warnings; 5 | 6 | use base 'Protocol::SocketIO::Message'; 7 | 8 | 1; 9 | __END__ 10 | 11 | =head1 NAME 12 | 13 | PocketIO::Message - Socket.IO message parsing and building 14 | 15 | =head1 DESCRIPTION 16 | 17 | L parsers and builds Socket.IO messages. 18 | 19 | =cut 20 | -------------------------------------------------------------------------------- /lib/PocketIO/Pool.pm: -------------------------------------------------------------------------------- 1 | package PocketIO::Pool; 2 | 3 | use strict; 4 | use warnings; 5 | 6 | use Scalar::Util qw(blessed); 7 | 8 | use PocketIO::Connection; 9 | 10 | use constant DEBUG => $ENV{POCKETIO_POOL_DEBUG}; 11 | 12 | sub new { 13 | my $class = shift; 14 | 15 | my $self = {@_}; 16 | bless $self, $class; 17 | 18 | $self->{connections} = {}; 19 | $self->{rooms} = {}; 20 | $self->{revrooms} = {}; 21 | 22 | return $self; 23 | } 24 | 25 | sub find_local_connection { 26 | my $self = shift; 27 | my ($conn) = @_; 28 | 29 | my $id = blessed $conn ? $conn->id : $conn; 30 | 31 | return $self->{connections}->{$id}; 32 | } 33 | 34 | sub find_connection { 35 | my $self = shift; 36 | 37 | return $self->find_local_connection(@_); 38 | } 39 | 40 | sub add_connection { 41 | my $self = shift; 42 | my $cb = pop @_; 43 | 44 | my $conn = $self->_build_connection(@_); 45 | 46 | $self->{connections}->{$conn->id} = $conn; 47 | 48 | DEBUG && warn "Added connection '" . $conn->id . "'\n"; 49 | 50 | return $cb->($conn); 51 | } 52 | 53 | sub remove_connection { 54 | my $self = shift; 55 | my ($conn, $cb) = @_; 56 | 57 | my $id = blessed $conn ? $conn->id : $conn; 58 | 59 | delete $self->{connections}->{$id}; 60 | foreach my $room (keys %{$self->{revrooms}{$id}}) { 61 | delete $self->{rooms}{$room}{$id}; 62 | } 63 | delete $self->{revrooms}{$id}; 64 | 65 | DEBUG && warn "Removed connection '" . $id . "'\n"; 66 | 67 | return $cb->() if $cb; 68 | } 69 | 70 | sub room_join { 71 | my $self = shift; 72 | my $room = shift; 73 | my $conn = shift; 74 | 75 | my $id = blessed $conn ? $conn->id : $conn; 76 | $conn = $self->{connections}->{$id}; 77 | 78 | $self->{rooms}{$room}{$id} = $conn; 79 | $self->{revrooms}{$id}{$room} = $conn; 80 | return $conn; 81 | } 82 | 83 | sub room_leave { 84 | my $self = shift; 85 | my $room = shift; 86 | my $conn = shift; 87 | my ($subrooms) = @_; 88 | 89 | my $id = blessed $conn ? $conn->id : $conn; 90 | 91 | if ($subrooms) { 92 | DEBUG && warn "Deleting '$id' subrooms of '$room'\n"; 93 | foreach my $subroom (keys %{$self->{revrooms}{$id}}) { 94 | if ($subroom =~ /^\Q$room\E/) { 95 | delete $self->{rooms}{$subroom}{$id}; 96 | delete $self->{revrooms}{$id}{$subroom}; 97 | } 98 | } 99 | } 100 | else { 101 | DEBUG && warn "Deleting just '$id' room '$room'\n"; 102 | delete $self->{rooms}{$room}{$id}; 103 | delete $self->{revrooms}{$id}{$room}; 104 | } 105 | return $conn; 106 | } 107 | 108 | sub send_raw { 109 | my $self = shift; 110 | my ($msg) = {@_}; 111 | 112 | if (defined $msg->{id}) { 113 | 114 | # Message directly to a connection. 115 | my $conn = $self->find_local_connection($msg->{id}); 116 | if (defined $conn) { 117 | 118 | # Send the message here and now. 119 | DEBUG && warn "Sending message to $msg->{id}\n"; 120 | if (defined $msg->{bytes}) { 121 | $conn->write($msg->{bytes}); 122 | } 123 | else { 124 | $conn->send($msg->{message}); 125 | } 126 | } 127 | return $conn; 128 | } 129 | 130 | my @members = 131 | defined $msg->{room} 132 | ? values %{$self->{rooms}{$msg->{room}}} 133 | : $self->_connections; 134 | 135 | foreach my $conn (@members) { 136 | next unless blessed $conn && $conn->is_connected; 137 | next if defined $msg->{invoker} && $conn->id eq $msg->{invoker}->id; 138 | 139 | DEBUG && warn "Sending message to " . $conn->id . "\n"; 140 | $conn->socket->send($msg->{message}); 141 | } 142 | 143 | return $self; 144 | } 145 | 146 | sub send { 147 | my $self = shift; 148 | 149 | return $self->send_raw(message => $_[0]); 150 | } 151 | 152 | sub broadcast { 153 | my $self = shift; 154 | my $invoker = shift; 155 | 156 | return $self->send_raw(message => $_[0], invoker => $invoker); 157 | } 158 | 159 | sub _connections { 160 | my $self = shift; 161 | 162 | return values %{$self->{connections}}; 163 | } 164 | 165 | sub _build_connection { 166 | my $self = shift; 167 | 168 | return PocketIO::Connection->new( 169 | @_, 170 | pool => $self, 171 | on_connect_failed => sub { $self->remove_connection(@_) }, 172 | on_reconnect_failed => sub { 173 | my $conn = shift; 174 | 175 | $conn->disconnected; 176 | 177 | $self->remove_connection($conn); 178 | } 179 | ); 180 | } 181 | 182 | 1; 183 | __END__ 184 | 185 | =head1 NAME 186 | 187 | PocketIO::Pool - Connection pool 188 | 189 | =head1 DESCRIPTION 190 | 191 | L is a connection pool. 192 | 193 | =head1 METHODS 194 | 195 | =head2 C 196 | 197 | =head2 C 198 | 199 | =head2 C 200 | 201 | =head2 C 202 | 203 | =head2 C 204 | 205 | =head2 C 206 | 207 | =head2 C 208 | 209 | =cut 210 | -------------------------------------------------------------------------------- /lib/PocketIO/Pool/Redis.pm: -------------------------------------------------------------------------------- 1 | package PocketIO::Pool::Redis; 2 | 3 | use strict; 4 | use warnings; 5 | 6 | use base 'PocketIO::Pool'; 7 | 8 | use AnyEvent::Redis; 9 | use JSON; 10 | use Scalar::Util qw(blessed); 11 | 12 | use PocketIO::Connection; 13 | 14 | use constant DEBUG => $ENV{POCKETIO_POOL_DEBUG}; 15 | 16 | sub new { 17 | my $self = shift->SUPER::new(@_); 18 | 19 | $self->{channel} ||= 'pocketio'; 20 | 21 | $self->{redis} ||= {}; 22 | 23 | $self->{pub} = $self->_create_client(%{$self->{redis}}); 24 | $self->{sub} = $self->_create_client(%{$self->{redis}}); 25 | 26 | $self->{sub}->subscribe( 27 | $self->{channel} => sub { 28 | my ($message, $channel) = @_; 29 | 30 | $message = decode_json($message); 31 | 32 | my $invoker_id = $message->{invoker}; 33 | 34 | foreach my $conn ($self->_connections) { 35 | next unless $conn->is_connected; 36 | next if defined $invoker_id && $conn->id eq $invoker_id; 37 | 38 | $conn->write($message->{message}); 39 | } 40 | } 41 | ); 42 | 43 | return $self; 44 | } 45 | 46 | sub add_connection { 47 | my $self = shift; 48 | my $cb = pop @_; 49 | 50 | my $conn = $self->_build_connection(@_); 51 | 52 | $self->{connections}->{$conn->id} = $conn; 53 | 54 | DEBUG && warn "Added connection '" . $conn->id . "'\n"; 55 | 56 | $cb->($conn); 57 | } 58 | 59 | sub remove_connection { 60 | my $self = shift; 61 | my ($conn, $cb) = @_; 62 | 63 | my $id = blessed $conn ? $conn->id : $conn; 64 | 65 | delete $self->{connections}->{$id}; 66 | 67 | DEBUG && warn "Removed connection '" . $id . "'\n"; 68 | 69 | $cb->() if $cb; 70 | } 71 | 72 | sub send { 73 | my $self = shift; 74 | 75 | my $message = encode_json({message => "$_[0]"}); 76 | 77 | $self->{pub}->publish($self->{channel}, $message); 78 | 79 | return $self; 80 | } 81 | 82 | sub broadcast { 83 | my $self = shift; 84 | my $invoker = shift; 85 | 86 | my $message = encode_json({message => "$_[0]", invoker => $invoker->id}); 87 | 88 | $self->{pub}->publish($self->{channel}, $message); 89 | 90 | return $self; 91 | } 92 | 93 | sub _create_client { 94 | my $self = shift; 95 | 96 | return AnyEvent::Redis->new( 97 | host => '127.0.0.1', 98 | port => 6379, 99 | encoding => 'utf8', 100 | on_error => sub { 101 | warn @_; 102 | }, 103 | @_ 104 | ); 105 | } 106 | 107 | 1; 108 | __END__ 109 | 110 | =head1 NAME 111 | 112 | PocketIO::Pool::Redis - Redis class 113 | 114 | =head1 SYNOPSIS 115 | 116 | my $pocketio = PocketIO->new(pool => PocketIO::Pool::Redis->new); 117 | 118 | =head1 DESCRIPTION 119 | 120 | Uses Redis' pub/sub infrastructure 121 | 122 | =head1 METHODS 123 | 124 | =head2 C 125 | 126 | Create new instance. 127 | 128 | =head2 C 129 | 130 | Add new connection. 131 | 132 | =head2 C 133 | 134 | Remove connection. 135 | 136 | =head2 C 137 | 138 | Send broadcast message. 139 | 140 | =head2 C 141 | 142 | Send message to all client. 143 | 144 | =cut 145 | -------------------------------------------------------------------------------- /lib/PocketIO/Resource.pm: -------------------------------------------------------------------------------- 1 | package PocketIO::Resource; 2 | 3 | use strict; 4 | use warnings; 5 | 6 | use Protocol::SocketIO::Handshake; 7 | use Protocol::SocketIO::Path; 8 | 9 | use PocketIO::Exception; 10 | use PocketIO::Transport::Htmlfile; 11 | use PocketIO::Transport::JSONPPolling; 12 | use PocketIO::Transport::WebSocket; 13 | use PocketIO::Transport::XHRMultipart; 14 | use PocketIO::Transport::XHRPolling; 15 | use PocketIO::Util; 16 | 17 | use constant DEBUG => $ENV{POCKETIO_RESOURCE_DEBUG}; 18 | 19 | my %TRANSPORTS = ( 20 | 'flashsocket' => 'WebSocket', 21 | 'htmlfile' => 'Htmlfile', 22 | 'jsonp-polling' => 'JSONPPolling', 23 | 'websocket' => 'WebSocket', 24 | 25 | # 'xhr-multipart' => 'XHRMultipart', 26 | 'xhr-polling' => 'XHRPolling', 27 | ); 28 | 29 | sub new { 30 | my $class = shift; 31 | 32 | my $self = {@_}; 33 | bless $self, $class; 34 | 35 | $self->{heartbeat_timeout} ||= 15; 36 | $self->{close_timeout} ||= 25; 37 | $self->{max_connections} ||= 100; 38 | 39 | $self->{transports} 40 | ||= [qw/websocket flashsocket htmlfile xhr-polling jsonp-polling/]; 41 | 42 | return $self; 43 | } 44 | 45 | sub dispatch { 46 | my $self = shift; 47 | my ($env, $cb) = @_; 48 | 49 | my $method = $env->{REQUEST_METHOD}; 50 | 51 | PocketIO::Exception->throw(400 => 'Unexpected method') 52 | unless $method eq 'POST' || $method eq 'GET'; 53 | 54 | my $path_info = $env->{PATH_INFO}; 55 | 56 | my $path = 57 | Protocol::SocketIO::Path->new(transports => $self->{transports}) 58 | ->parse($path_info); 59 | PocketIO::Exception->throw(400 => 'Cannot parse path') unless $path; 60 | 61 | if ($path->is_handshake) { 62 | return $self->_dispatch_handshake($env, $cb); 63 | } 64 | 65 | my $conn = $self->_find_connection($path->session_id); 66 | PocketIO::Exception->throw(400 => 'Unknown session id') unless $conn; 67 | 68 | my $transport = $self->_build_transport( 69 | $path->transport_type, 70 | env => $env, 71 | conn => $conn, 72 | handle => $self->_build_handle($env), 73 | on_disconnect => sub { $self->{pool}->remove_connection($conn) } 74 | ); 75 | 76 | $conn->type($path->transport_type); 77 | 78 | my $dispatch = eval { $transport->dispatch } or do { 79 | my $e = $@; 80 | warn $e if DEBUG; 81 | die $e; 82 | }; 83 | 84 | return $dispatch; 85 | } 86 | 87 | sub _build_handle { 88 | my $self = shift; 89 | my ($env) = @_; 90 | 91 | return PocketIO::Handle->new( 92 | heartbeat_timeout => $self->{heartbeat_timeout}, 93 | fh => $env->{'psgix.io'} 94 | ); 95 | } 96 | 97 | sub _dispatch_handshake { 98 | my $self = shift; 99 | my ($env, $cb) = @_; 100 | 101 | return sub { 102 | my $respond = shift; 103 | 104 | eval { 105 | $self->_build_connection( 106 | on_connect => $cb, 107 | on_connect_args => [$env], 108 | $self->_on_connection_created($env, $respond) 109 | ); 110 | 111 | 1; 112 | } or do { 113 | my $e = $@; 114 | 115 | warn "Handshake error: $e"; 116 | 117 | PocketIO::Exception->throw(503 => 'Service unavailable'); 118 | }; 119 | }; 120 | } 121 | 122 | sub _build_connection { 123 | my $self = shift; 124 | 125 | $self->{pool}->add_connection(@_); 126 | } 127 | 128 | sub _on_connection_created { 129 | my $self = shift; 130 | my ($env, $respond) = @_; 131 | 132 | return sub { 133 | my $conn = shift; 134 | 135 | my $handshake = Protocol::SocketIO::Handshake->new( 136 | session_id => $conn->id, 137 | transports => $self->{transports}, 138 | heartbeat_timeout => $self->{heartbeat_timeout}, 139 | close_timeout => $self->{close_timeout} 140 | )->to_bytes; 141 | 142 | my $headers = []; 143 | 144 | my $jsonp = 145 | PocketIO::Util::urlencoded_param($env->{QUERY_STRING}, 'jsonp'); 146 | 147 | # XDomain request 148 | if (defined $jsonp) { 149 | push @$headers, 'Content-Type' => 'application/javascript'; 150 | $handshake = qq{io.j[$jsonp]("$handshake");}; 151 | } 152 | else { 153 | push @$headers, 'Content-Type' => 'text/plain'; 154 | } 155 | 156 | push @$headers, 'Connection' => 'keep-alive'; 157 | push @$headers, 'Content-Length' => length($handshake); 158 | 159 | $respond->([200, $headers, [$handshake]]); 160 | }; 161 | } 162 | 163 | sub _find_connection { 164 | my $self = shift; 165 | 166 | return $self->{pool}->find_connection(@_); 167 | } 168 | 169 | sub _build_transport { 170 | my $self = shift; 171 | my ($type, @args) = @_; 172 | 173 | PocketIO::Exception->throw(400 => 'Transport building failed') 174 | unless exists $TRANSPORTS{$type}; 175 | 176 | my $class = "PocketIO::Transport::$TRANSPORTS{$type}"; 177 | 178 | DEBUG && warn "Building $class\n"; 179 | 180 | return $class->new(@args); 181 | } 182 | 183 | 1; 184 | __END__ 185 | 186 | =head1 NAME 187 | 188 | PocketIO::Resource - Resource class 189 | 190 | =head1 DESCRIPTION 191 | 192 | L is a transport dispatcher. 193 | 194 | =head1 METHODS 195 | 196 | =head2 C 197 | 198 | =head2 C 199 | 200 | =cut 201 | -------------------------------------------------------------------------------- /lib/PocketIO/Room.pm: -------------------------------------------------------------------------------- 1 | package PocketIO::Room; 2 | 3 | use strict; 4 | use warnings; 5 | 6 | use PocketIO::Message; 7 | 8 | sub new { 9 | my $class = shift; 10 | 11 | my $self = {@_}; 12 | bless $self, $class; 13 | 14 | return $self; 15 | } 16 | 17 | sub send { 18 | my $self = shift; 19 | 20 | $self->{pool}->send_raw( 21 | room => $self->{room}, 22 | invoker => $self->{conn}, 23 | message => $_[0], 24 | ); 25 | 26 | return $self; 27 | } 28 | 29 | sub emit { 30 | my $self = shift; 31 | my $name = shift; 32 | 33 | my $event = $self->_build_event_message($name, @_); 34 | 35 | $self->{pool}->send_raw( 36 | room => $self->{room}, 37 | invoker => $self->{conn}, 38 | message => $event 39 | ); 40 | 41 | return $self; 42 | } 43 | 44 | sub _build_event_message { 45 | my $self = shift; 46 | my $event = shift; 47 | 48 | return PocketIO::Message->new( 49 | type => 'event', 50 | data => {name => $event, args => [@_]} 51 | ); 52 | } 53 | 54 | 1; 55 | -------------------------------------------------------------------------------- /lib/PocketIO/Socket.pm: -------------------------------------------------------------------------------- 1 | package PocketIO::Socket; 2 | 3 | use strict; 4 | use warnings; 5 | 6 | use PocketIO::Message; 7 | 8 | # DEPRECATED 9 | sub send_message {&send} 10 | sub send_broadcast { shift->broadcast->send(@_) } 11 | sub send_broadcast_to_all { shift->sockets->send(@_) } 12 | sub emit_broadcast { shift->broadcast->emit(@_) } 13 | sub emit_broadcast_to_all { shift->sockets->emit(@_) } 14 | 15 | sub new { 16 | my $class = shift; 17 | 18 | my $self = {@_}; 19 | bless $self, $class; 20 | 21 | $self->{data} ||= {}; 22 | 23 | return $self; 24 | } 25 | 26 | sub session_id {&id} 27 | sub id { $_[0]->{conn}->id } 28 | 29 | sub set { 30 | my $self = shift; 31 | my ($key, $value, $cb) = @_; 32 | 33 | $self->{data}->{$key} = $value; 34 | $cb->($self) if $cb; 35 | 36 | return $self; 37 | } 38 | 39 | sub get { 40 | my $self = shift; 41 | my ($key, $cb) = @_; 42 | 43 | my $value = $self->{data}->{$key}; 44 | 45 | $cb->($self, undef, $value); 46 | 47 | return $self; 48 | } 49 | 50 | sub on { 51 | my $self = shift; 52 | my $event = shift; 53 | 54 | my $name = "on_$event"; 55 | 56 | unless (@_) { 57 | return $self->{$name}; 58 | } 59 | 60 | $self->{$name} = $_[0]; 61 | 62 | return $self; 63 | } 64 | 65 | sub emit { 66 | my $self = shift; 67 | my $event = shift; 68 | 69 | $event = $self->_build_event_message($event, @_); 70 | 71 | $self->send($event); 72 | 73 | return $self; 74 | } 75 | 76 | sub send { 77 | my $self = shift; 78 | 79 | $self->{conn}->send(@_); 80 | 81 | return $self; 82 | } 83 | 84 | sub broadcast { 85 | my $self = shift; 86 | 87 | return $self->{conn}->broadcast(@_); 88 | } 89 | 90 | sub sockets { 91 | my $self = shift; 92 | 93 | return $self->{conn}->sockets(@_); 94 | } 95 | 96 | sub close { 97 | my $self = shift; 98 | 99 | $self->{conn}->close; 100 | 101 | return $self; 102 | } 103 | 104 | sub join { 105 | my $self = shift; 106 | my $room = shift; 107 | 108 | return $self->{conn}->pool->room_join($room, $self->{conn}); 109 | } 110 | 111 | sub leave { 112 | my $self = shift; 113 | my $room = shift; 114 | 115 | return $self->{conn}->pool->room_leave($room, $self->{conn}); 116 | } 117 | 118 | sub _build_event_message { 119 | my $self = shift; 120 | my $event = shift; 121 | 122 | return PocketIO::Message->new( 123 | type => 'event', 124 | data => {name => $event, args => [@_]} 125 | ); 126 | } 127 | 128 | 1; 129 | __END__ 130 | 131 | =head1 NAME 132 | 133 | PocketIO::Socket - Socket class 134 | 135 | =head1 DESCRIPTION 136 | 137 | Instance of L is actually the object that you get in a 138 | handler. 139 | 140 | builder { 141 | mount '/socket.io' => PocketIO->new( 142 | handler => sub { 143 | my $socket = shift; 144 | 145 | # $socket is PocketIO::Socket instance 146 | } 147 | ); 148 | 149 | ... 150 | }; 151 | 152 | =head1 METHODS 153 | 154 | =head2 C 155 | 156 | Create new instance. 157 | 158 | =head2 C 159 | 160 | Close connection. 161 | 162 | =head2 C 163 | 164 | Emit event. 165 | 166 | =head2 C 167 | 168 | Get attribute. 169 | 170 | =head2 C 171 | 172 | Set atribute. 173 | 174 | =head2 C 175 | 176 | Get session id. 177 | 178 | =head2 C 179 | 180 | Same as C. 181 | 182 | =head2 C 183 | 184 | Register event. 185 | 186 | =head2 C 187 | 188 | Send message. 189 | 190 | =head2 C 191 | 192 | Get sockets object. 193 | 194 | =head2 C 195 | 196 | Get broadcasting object. 197 | 198 | =head2 C 199 | 200 | Join the specified room. 201 | 202 | =head2 C 203 | 204 | Leave the specified room. 205 | 206 | =cut 207 | -------------------------------------------------------------------------------- /lib/PocketIO/Sockets.pm: -------------------------------------------------------------------------------- 1 | package PocketIO::Sockets; 2 | 3 | use strict; 4 | use warnings; 5 | 6 | use PocketIO::Message; 7 | use PocketIO::Room; 8 | 9 | sub new { 10 | my $class = shift; 11 | 12 | my $self = {@_}; 13 | bless $self, $class; 14 | 15 | return $self; 16 | } 17 | 18 | sub send { 19 | my $self = shift; 20 | 21 | $self->{pool}->send(@_); 22 | 23 | return $self; 24 | } 25 | 26 | sub emit { 27 | my $self = shift; 28 | my $name = shift; 29 | 30 | my $event = $self->_build_event_message($name, @_); 31 | 32 | $self->{pool}->send($event); 33 | 34 | return $self; 35 | } 36 | 37 | sub in { 38 | my $self = shift; 39 | my ($room) = @_; 40 | 41 | return PocketIO::Room->new(room => $room, pool => $self->{pool}); 42 | } 43 | 44 | sub _build_event_message { 45 | my $self = shift; 46 | my $event = shift; 47 | 48 | return PocketIO::Message->new( 49 | type => 'event', 50 | data => {name => $event, args => [@_]} 51 | ); 52 | } 53 | 54 | 1; 55 | __END__ 56 | 57 | =head1 NAME 58 | 59 | PocketIO::Sockets - Sockets class 60 | 61 | =head1 DESCRIPTION 62 | 63 | Used to send messages to B clients. 64 | 65 | =head1 METHODS 66 | 67 | =head2 C 68 | 69 | Create new instance. 70 | 71 | =head2 C 72 | 73 | Send message. 74 | 75 | =head2 C 76 | 77 | Emit event. 78 | 79 | =cut 80 | -------------------------------------------------------------------------------- /lib/PocketIO/Test.pm: -------------------------------------------------------------------------------- 1 | package PocketIO::Test; 2 | 3 | use strict; 4 | use warnings; 5 | 6 | use AnyEvent; 7 | use AnyEvent::Socket; 8 | use Test::TCP; 9 | use Plack::Loader; 10 | 11 | use parent qw(Exporter); 12 | our @EXPORT = qw(test_pocketio http_get_session_id); 13 | 14 | sub test_pocketio { 15 | my ($app, $client) = @_; 16 | 17 | test_tcp( 18 | client => $client, 19 | server => sub { 20 | my $port = shift; 21 | my $server = Plack::Loader->load( 22 | 'Twiggy', 23 | port => $port, 24 | host => ('127.0.0.1') 25 | ); 26 | $server->run($app); 27 | }, 28 | ); 29 | } 30 | 31 | sub http_get_session_id { 32 | my $server = shift; 33 | my $port = shift; 34 | 35 | my $cv = AnyEvent->condvar; 36 | 37 | my $session_id; 38 | 39 | $cv->begin; 40 | tcp_connect $server, $port, sub { 41 | my ($fh) = @_ or return $cv->send; 42 | 43 | syswrite $fh, <<"EOF"; 44 | GET /socket.io/1/ HTTP/1.1 45 | Host: $server:$port 46 | 47 | EOF 48 | 49 | my $buffer = ''; 50 | 51 | my $read_watcher; 52 | $read_watcher = AnyEvent->io( 53 | fh => $fh, 54 | poll => "r", 55 | cb => sub { 56 | my $len = sysread $fh, my $chunk, 1024, 0; 57 | 58 | $buffer .= $chunk; 59 | 60 | if ($len <= 0) { 61 | ($session_id) = $buffer =~ m/\r?\n(\d+):/; 62 | 63 | undef $read_watcher; 64 | return $cv->end; 65 | } 66 | } 67 | ); 68 | }; 69 | 70 | $cv->wait; 71 | 72 | return $session_id; 73 | } 74 | 75 | 1; 76 | __END__ 77 | 78 | =head1 NAME 79 | 80 | PocketIO::Test - Testing PocketIO 81 | 82 | =head1 DESCRIPTION 83 | 84 | L is a L testing simplified. 85 | 86 | =head1 FUNCTIONS 87 | 88 | =head2 C 89 | 90 | =head2 C 91 | 92 | =cut 93 | -------------------------------------------------------------------------------- /lib/PocketIO/Transport/Base.pm: -------------------------------------------------------------------------------- 1 | package PocketIO::Transport::Base; 2 | 3 | use strict; 4 | use warnings; 5 | 6 | use Scalar::Util qw(weaken); 7 | 8 | sub new { 9 | my $class = shift; 10 | 11 | my $self = bless {@_}, $class; 12 | 13 | weaken $self->{env}; 14 | weaken $self->{conn}; 15 | 16 | return $self; 17 | } 18 | 19 | sub env { $_[0]->{env} } 20 | sub conn { $_[0]->{conn} } 21 | 22 | sub client_connected { 23 | my $self = shift; 24 | my ($conn) = @_; 25 | 26 | return if $conn->is_connected; 27 | 28 | $conn->connected; 29 | } 30 | 31 | sub client_disconnected { 32 | my $self = shift; 33 | my ($conn) = @_; 34 | 35 | $conn->disconnected; 36 | 37 | $self->{on_disconnect}->($self); 38 | 39 | return $self; 40 | } 41 | 42 | 1; 43 | __END__ 44 | 45 | =head1 NAME 46 | 47 | PocketIO::Transport::Base - Base class for transports 48 | 49 | =head1 DESCRIPTION 50 | 51 | L is a base class for the transports. 52 | 53 | =head1 METHODS 54 | 55 | =head2 C 56 | 57 | =head2 C 58 | 59 | =head2 C 60 | 61 | =head2 C 62 | 63 | =head2 C 64 | 65 | =head2 C 66 | 67 | =cut 68 | -------------------------------------------------------------------------------- /lib/PocketIO/Transport/BasePolling.pm: -------------------------------------------------------------------------------- 1 | package PocketIO::Transport::BasePolling; 2 | 3 | use strict; 4 | use warnings; 5 | 6 | use base 'PocketIO::Transport::Base'; 7 | 8 | use PocketIO::Exception; 9 | 10 | sub dispatch { 11 | my $self = shift; 12 | 13 | if ($self->{env}->{REQUEST_METHOD} eq 'GET') { 14 | return $self->_dispatch_stream; 15 | } 16 | 17 | return $self->_dispatch_send; 18 | } 19 | 20 | sub _dispatch_stream { 21 | my $self = shift; 22 | 23 | my $conn = $self->conn; 24 | 25 | my $handle = $self->{handle}; 26 | 27 | return sub { 28 | my $respond = shift; 29 | 30 | my $close_cb = 31 | sub { $handle->close; $self->client_disconnected($conn); }; 32 | $handle->on_eof($close_cb); 33 | $handle->on_error($close_cb); 34 | 35 | $handle->on_heartbeat(sub { $conn->send_heartbeat }); 36 | 37 | if ($conn->has_staged_messages) { 38 | $self->_write($conn, $handle, $conn->staged_message); 39 | } 40 | else { 41 | $conn->on( 42 | write => sub { 43 | my $conn = shift; 44 | my ($message) = @_; 45 | 46 | $conn->on(write => undef); 47 | $self->_write($conn, $handle, $message); 48 | } 49 | ); 50 | } 51 | 52 | $conn->on(close => $close_cb); 53 | 54 | if ($conn->is_connected) { 55 | $conn->reconnected; 56 | } 57 | else { 58 | $self->client_connected($conn); 59 | } 60 | }; 61 | } 62 | 63 | sub _dispatch_send { 64 | my $self = shift; 65 | 66 | my $conn = $self->conn; 67 | 68 | my $data = $self->_get_content; 69 | 70 | $conn->parse_message($data); 71 | 72 | return [200, ['Content-Length' => 1], ['1']]; 73 | } 74 | 75 | sub _get_content { 76 | my $self = shift; 77 | 78 | my $content_length = $self->{env}->{CONTENT_LENGTH} || 0; 79 | my $rcount = 80 | $self->{env}->{'psgi.input'}->read(my $chunk, $content_length); 81 | 82 | PocketIO::Exception->throw(500) unless $rcount == $content_length; 83 | 84 | return $chunk; 85 | } 86 | 87 | sub _content_type {'text/plain'} 88 | 89 | sub _write { 90 | my $self = shift; 91 | my ($conn, $handle, $message) = @_; 92 | 93 | $message = $self->_format_message($message); 94 | 95 | $handle->write( 96 | join( 97 | "\x0d\x0a" => 'HTTP/1.1 200 OK', 98 | 'Content-Type: ' . $self->_content_type, 99 | 'Content-Length: ' . length($message), 100 | 'Access-Control-Allow-Origin: *', 101 | 'Access-Control-Allow-Credentials: *', 102 | '', $message, 103 | ), 104 | sub { 105 | $handle->close; 106 | $conn->reconnecting; 107 | } 108 | ); 109 | } 110 | 111 | sub _format_message { $_[1] } 112 | 113 | 1; 114 | __END__ 115 | 116 | =head1 NAME 117 | 118 | PocketIO::Transport::BasePolling - Basic class for polling transports 119 | 120 | =head1 DESCRIPTION 121 | 122 | Basic class for polling transports. 123 | 124 | =head1 METHODS 125 | 126 | =head2 dispatch 127 | 128 | =cut 129 | -------------------------------------------------------------------------------- /lib/PocketIO/Transport/Htmlfile.pm: -------------------------------------------------------------------------------- 1 | package PocketIO::Transport::Htmlfile; 2 | 3 | use strict; 4 | use warnings; 5 | 6 | use base 'PocketIO::Transport::Base'; 7 | 8 | sub dispatch { 9 | my $self = shift; 10 | 11 | if ($self->{env}->{REQUEST_METHOD} eq 'GET') { 12 | return $self->_dispatch_stream; 13 | } 14 | 15 | return $self->_dispatch_send; 16 | } 17 | 18 | sub _dispatch_stream { 19 | my $self = shift; 20 | 21 | my $conn = $self->conn; 22 | 23 | my $handle = $self->{handle}; 24 | 25 | return sub { 26 | my $close_cb = 27 | sub { $handle->close; $self->client_disconnected($conn); }; 28 | $handle->on_eof($close_cb); 29 | $handle->on_error($close_cb); 30 | 31 | $handle->on_heartbeat(sub { $conn->send_heartbeat }); 32 | 33 | $handle->write( 34 | join "\x0d\x0a" => 'HTTP/1.1 200 OK', 35 | 'Content-Type: text/html', 36 | 'Connection: keep-alive', 37 | 'Transfer-Encoding: chunked', 38 | 'Access-Control-Allow-Origin: *', 39 | 'Access-Control-Allow-Credentials: *', 40 | '', 41 | sprintf('%x', 173 + 83), 42 | '' 43 | . (' ' x 173), 44 | '' 45 | ); 46 | 47 | $conn->on( 48 | write => sub { 49 | my $conn = shift; 50 | my ($message) = @_; 51 | 52 | $message = $self->_format_message($message); 53 | 54 | $handle->write( 55 | join "\x0d\x0a" => sprintf('%x', length($message)), 56 | $message, 57 | '' 58 | ); 59 | } 60 | ); 61 | 62 | $conn->on(close => $close_cb); 63 | 64 | $self->client_connected($conn); 65 | }; 66 | } 67 | 68 | sub _dispatch_send { 69 | my $self = shift; 70 | 71 | my $content_length = $self->{env}->{CONTENT_LENGTH} || 0; 72 | my $rcount = 73 | $self->{env}->{'psgi.input'}->read(my $chunk, $content_length); 74 | 75 | PocketIO::Exception->throw(500) unless $rcount == $content_length; 76 | 77 | $self->conn->parse_message($chunk); 78 | 79 | return [200, ['Content-Length' => 1], ['1']]; 80 | } 81 | 82 | sub _format_message { 83 | my $self = shift; 84 | my ($message) = @_; 85 | 86 | $message =~ s/"/\\"/g; 87 | return qq{}; 88 | } 89 | 90 | 1; 91 | __END__ 92 | 93 | =head1 NAME 94 | 95 | PocketIO::Transport::Htmlfile - Htmlfile transport 96 | 97 | =head1 DESCRIPTION 98 | 99 | L is a C transport implementation. 100 | 101 | =head1 METHODS 102 | 103 | =over 104 | 105 | =item dispatch 106 | 107 | =back 108 | 109 | =cut 110 | -------------------------------------------------------------------------------- /lib/PocketIO/Transport/JSONPPolling.pm: -------------------------------------------------------------------------------- 1 | package PocketIO::Transport::JSONPPolling; 2 | 3 | use strict; 4 | use warnings; 5 | 6 | use base 'PocketIO::Transport::BasePolling'; 7 | 8 | use PocketIO::Util; 9 | 10 | sub _get_content { 11 | my $self = shift; 12 | 13 | my $content = $self->SUPER::_get_content; 14 | 15 | return PocketIO::Util::urlencoded_param($content, 'd'); 16 | } 17 | 18 | sub _content_type {'text/javascript; charset=UTF-8'} 19 | 20 | sub _format_message { 21 | my $self = shift; 22 | my ($message) = @_; 23 | 24 | $message =~ s/"/\\"/g; 25 | return qq{io.j[0]("$message");}; 26 | } 27 | 28 | 1; 29 | __END__ 30 | 31 | =head1 NAME 32 | 33 | PocketIO::Transport::JSONPPolling - JSONPPolling transport 34 | 35 | =head1 DESCRIPTION 36 | 37 | L is a C transport implementation. 38 | 39 | =head1 METHODS 40 | 41 | Inherits all methods from L. 42 | 43 | =cut 44 | -------------------------------------------------------------------------------- /lib/PocketIO/Transport/WebSocket.pm: -------------------------------------------------------------------------------- 1 | package PocketIO::Transport::WebSocket; 2 | 3 | use strict; 4 | use warnings; 5 | 6 | use base 'PocketIO::Transport::Base'; 7 | 8 | use Protocol::WebSocket::Frame; 9 | use Protocol::WebSocket::Handshake::Server; 10 | 11 | use PocketIO::Exception; 12 | use PocketIO::Handle; 13 | 14 | sub dispatch { 15 | my $self = shift; 16 | 17 | my $handle = $self->{handle}; 18 | 19 | my $hs = 20 | Protocol::WebSocket::Handshake::Server->new_from_psgi($self->{env}); 21 | PocketIO::Exception->throw(500, 'WebSocket failed: ' . $hs->error) 22 | unless $hs->parse($handle->fh); 23 | 24 | return unless $hs->is_done; 25 | 26 | my $version = $hs->version; 27 | 28 | my $frame = Protocol::WebSocket::Frame->new(version => $version); 29 | 30 | return sub { 31 | my $respond = shift; 32 | 33 | $handle->write( 34 | $hs->to_string => sub { 35 | my $handle = shift; 36 | 37 | my $conn = $self->conn; 38 | 39 | my $close_cb = sub { 40 | $handle->close; 41 | $self->client_disconnected($conn); 42 | }; 43 | $handle->on_eof($close_cb); 44 | $handle->on_error($close_cb); 45 | 46 | $handle->on_heartbeat(sub { $conn->send_heartbeat }); 47 | 48 | $handle->on_read( 49 | sub { 50 | $frame->append($_[1]); 51 | 52 | while (my $message = $frame->next_bytes) { 53 | $conn->parse_message($message); 54 | } 55 | } 56 | ); 57 | 58 | $conn->on( 59 | close => sub { 60 | my $conn = shift; 61 | 62 | # $handle->write(); TODO write WebSocket EOF 63 | 64 | $handle->close; 65 | $self->client_disconnected($conn); 66 | } 67 | ); 68 | 69 | $conn->on( 70 | write => sub { 71 | my $bytes = $self->_build_frame( 72 | buffer => $_[1], 73 | version => $version 74 | ); 75 | 76 | $handle->write($bytes); 77 | } 78 | ); 79 | 80 | $self->client_connected($conn); 81 | } 82 | ); 83 | }; 84 | } 85 | 86 | sub _build_frame { 87 | my $self = shift; 88 | 89 | return Protocol::WebSocket::Frame->new(@_)->to_bytes; 90 | } 91 | 92 | 1; 93 | __END__ 94 | 95 | =head1 NAME 96 | 97 | PocketIO::Transport::WebSocket - WebSocket transport 98 | 99 | =head1 DESCRIPTION 100 | 101 | L is a WebSocket transport implementation. 102 | 103 | =head1 METHODS 104 | 105 | =head2 dispatch 106 | 107 | =head1 SEE ALSO 108 | 109 | L 110 | 111 | =cut 112 | -------------------------------------------------------------------------------- /lib/PocketIO/Transport/XHRMultipart.pm: -------------------------------------------------------------------------------- 1 | package PocketIO::Transport::XHRMultipart; 2 | 3 | use strict; 4 | use warnings; 5 | 6 | use base 'PocketIO::Transport::Base'; 7 | 8 | sub new { 9 | my $self = shift->SUPER::new(@_); 10 | 11 | $self->{boundary} ||= 'socketio'; 12 | 13 | return $self; 14 | } 15 | 16 | sub dispatch { 17 | my $self = shift; 18 | 19 | if ($self->{env}->{REQUEST_METHOD} eq 'GET') { 20 | return $self->_dispatch_stream; 21 | } 22 | 23 | return $self->_dispatch_send; 24 | } 25 | 26 | sub _dispatch_stream { 27 | my $self = shift; 28 | 29 | return sub { 30 | my $respond = shift; 31 | 32 | my $handle = $self->{handle}; 33 | 34 | my $conn = $self->conn; 35 | 36 | my $close_cb = sub { $handle->close; $self->client_disconnected($conn); }; 37 | $handle->on_eof($close_cb); 38 | $handle->on_error($close_cb); 39 | 40 | my $boundary = $self->{boundary}; 41 | 42 | $conn->on(write => 43 | sub { 44 | my $self = shift; 45 | my ($message) = @_; 46 | 47 | my $string = ''; 48 | 49 | $string .= "Content-Type: text/plain\x0a\x0a"; 50 | if ($message eq '') { 51 | $string .= "-1--$boundary--\x0a"; 52 | } 53 | else { 54 | $string .= "$message\x0a--$boundary\x0a"; 55 | } 56 | 57 | $handle->write($string); 58 | } 59 | ); 60 | 61 | $handle->on_heartbeat(sub { $conn->send_heartbeat }); 62 | 63 | $handle->write( 64 | join "\x0d\x0a" => 'HTTP/1.1 200 OK', 65 | qq{Content-Type: multipart/x-mixed-replace;boundary="$boundary"}, 66 | 'Access-Control-Allow-Origin: *', 67 | 'Access-Control-Allow-Credentials: *', 68 | 'Connection: keep-alive', '', '' 69 | ); 70 | 71 | $self->client_connected($conn); 72 | }; 73 | } 74 | 75 | sub _dispatch_send { 76 | my $self = shift; 77 | 78 | #my $data = $req->body_parameters->get('data'); 79 | 80 | #$self->conn->read($data); 81 | 82 | return [200, ['Content-Length' => 1], ['1']]; 83 | } 84 | 85 | 1; 86 | __END__ 87 | 88 | =head1 NAME 89 | 90 | PocketIO::Transport::XHRMultipart - XHRMultipart transport 91 | 92 | =head1 DESCRIPTION 93 | 94 | L is a C transport implementation. 95 | 96 | =head1 METHODS 97 | 98 | =head2 C 99 | 100 | =head2 C 101 | 102 | =cut 103 | -------------------------------------------------------------------------------- /lib/PocketIO/Transport/XHRPolling.pm: -------------------------------------------------------------------------------- 1 | package PocketIO::Transport::XHRPolling; 2 | 3 | use strict; 4 | use warnings; 5 | 6 | use base 'PocketIO::Transport::BasePolling'; 7 | 8 | 1; 9 | __END__ 10 | 11 | =head1 NAME 12 | 13 | PocketIO::Transport::XHRPolling - XHRPolling transport 14 | 15 | =head1 DESCRIPTION 16 | 17 | L is a C transport implementation. 18 | 19 | =head1 METHODS 20 | 21 | Inherict all methods from L. 22 | 23 | =cut 24 | -------------------------------------------------------------------------------- /lib/PocketIO/Util.pm: -------------------------------------------------------------------------------- 1 | package PocketIO::Util; 2 | 3 | use strict; 4 | use warnings; 5 | 6 | use base 'Exporter'; 7 | 8 | our @EXPORT_OK = (qw/urlencoded_param/); 9 | 10 | sub urlencoded_param { 11 | my ($string, $needed_key) = @_; 12 | 13 | return unless defined $string; 14 | 15 | my @pairs = split /(?:&|;)/, $string; 16 | for my $pair (@pairs) { 17 | my ($key, $value) = split /=/, $pair; 18 | 19 | $key =~ s/%([0-9A-Fa-f]{2})/chr(hex($1))/eg if defined $key; 20 | if ($key eq $needed_key) { 21 | $value =~ s/%([0-9A-Fa-f]{2})/chr(hex($1))/eg if defined $value; 22 | return $value; 23 | } 24 | } 25 | 26 | return; 27 | } 28 | 29 | 1; 30 | -------------------------------------------------------------------------------- /minil.toml: -------------------------------------------------------------------------------- 1 | name = "PocketIO" 2 | -------------------------------------------------------------------------------- /t/app.t: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings; 3 | 4 | use lib 't/lib'; 5 | 6 | use Test::More tests => 5; 7 | 8 | use_ok('PocketIO'); 9 | 10 | eval { 11 | PocketIO->new(app => sub { }); 12 | }; 13 | like $@ => qr/Either 'handler', 'class' or 'instance' must be specified/; 14 | 15 | my $env = {REQUEST_METHOD => 'GET', PATH_INFO => '/1/'}; 16 | 17 | my $app = PocketIO->new(app => sub { }, handler => sub { }); 18 | ok $app->($env); 19 | 20 | $app = PocketIO->new(app => sub { }, class => 'Handler'); 21 | ok $app->($env); 22 | 23 | $app = PocketIO->new(app => sub { }, instance => Handler->new); 24 | ok $app->($env); 25 | -------------------------------------------------------------------------------- /t/conn/broadcast.t: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings; 3 | 4 | use Test::More tests => 2; 5 | 6 | use_ok('PocketIO::Broadcast'); 7 | 8 | use PocketIO::Pool; 9 | use PocketIO::Broadcast; 10 | use PocketIO::Connection; 11 | 12 | my $pool = PocketIO::Pool->new; 13 | my $conn = PocketIO::Connection->new; 14 | 15 | my $broadcast = PocketIO::Broadcast->new(conn => $conn, pool => $pool); 16 | ok $broadcast; 17 | 18 | $broadcast->send(undef, 'foo'); 19 | $broadcast->emit(undef, 'bar'); 20 | -------------------------------------------------------------------------------- /t/conn/close-timeout.t: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings; 3 | 4 | use Test::More tests => 2; 5 | 6 | use AnyEvent; 7 | use Time::HiRes; 8 | 9 | use_ok('PocketIO::Connection'); 10 | 11 | my $cv = AnyEvent->condvar; 12 | 13 | my $failed; 14 | my $conn = PocketIO::Connection->new( 15 | close_timeout => 0.1, 16 | on_close => sub { 17 | $failed = 1; 18 | 19 | $cv->send; 20 | } 21 | ); 22 | $conn->connected; 23 | 24 | sleep 0.11; 25 | 26 | $cv->recv; 27 | 28 | ok $failed; 29 | -------------------------------------------------------------------------------- /t/conn/connect-timeout.t: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings; 3 | 4 | use Test::More tests => 3; 5 | 6 | use AnyEvent; 7 | use Time::HiRes; 8 | 9 | use_ok('PocketIO::Connection'); 10 | 11 | my $cv = AnyEvent->condvar; 12 | 13 | my $failed = 0; 14 | my $conn = PocketIO::Connection->new( 15 | connect_timeout => 0.1, 16 | on_connect_failed => sub { 17 | $failed = 1; 18 | 19 | $cv->send; 20 | } 21 | ); 22 | 23 | sleep 0.11; 24 | 25 | $cv->recv; 26 | 27 | ok $failed; 28 | 29 | $cv = AnyEvent->condvar; 30 | 31 | $failed = 0; 32 | $conn = PocketIO::Connection->new( 33 | connect_timeout => 1, 34 | on_connect => sub { 35 | $cv->send; 36 | }, 37 | on_connect_failed => sub { 38 | $failed = 1; 39 | 40 | $cv->send; 41 | } 42 | ); 43 | 44 | $conn->connected; 45 | 46 | $cv->recv; 47 | 48 | ok !$failed; 49 | -------------------------------------------------------------------------------- /t/conn/parsing.t: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings; 3 | use utf8; 4 | use Encode; 5 | 6 | use Test::More tests => 7; 7 | 8 | use_ok('PocketIO::Connection'); 9 | 10 | my $conn = PocketIO::Connection->new; 11 | ok $conn; 12 | 13 | my $output = ''; 14 | $conn->socket->on('message' => sub { $output = $_[1] }); 15 | 16 | $conn->parse_message('3:1::1234'); 17 | is $output => '1234'; 18 | 19 | $conn->parse_message('3:1::' . encode_utf8('привет')); 20 | is $output => 'привет'; 21 | 22 | $conn->parse_message('4:1::{"foo":"bar"}'); 23 | is_deeply $output => {foo => 'bar'}; 24 | 25 | $conn->parse_message('4:1::{"foo":"' . encode_utf8('привет') . '"}'); 26 | is_deeply $output => {foo => 'привет'}; 27 | 28 | ok $conn->parse_message('5:1::{"args":["foo"],"name":"foo"}'); 29 | -------------------------------------------------------------------------------- /t/conn/reconnect-timeout.t: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings; 3 | 4 | use Test::More tests => 3; 5 | 6 | use AnyEvent; 7 | use Time::HiRes; 8 | 9 | use_ok('PocketIO::Connection'); 10 | 11 | my $cv = AnyEvent->condvar; 12 | 13 | my $failed = 0; 14 | my $conn = PocketIO::Connection->new( 15 | reconnect_timeout => 0.1, 16 | on_reconnect_failed => sub { 17 | $failed = 1; 18 | 19 | $cv->send; 20 | } 21 | ); 22 | 23 | $conn->connected; 24 | $conn->reconnecting; 25 | 26 | sleep 0.11; 27 | 28 | $cv->recv; 29 | 30 | ok $failed; 31 | 32 | $cv = AnyEvent->condvar; 33 | 34 | $failed = 0; 35 | $conn = PocketIO::Connection->new( 36 | reconnect_timeout => 1, 37 | on_reconnect => sub { 38 | $cv->send; 39 | } 40 | ); 41 | 42 | $conn->connected; 43 | $conn->reconnecting; 44 | $conn->reconnected; 45 | 46 | $cv->recv; 47 | 48 | ok !$failed; 49 | -------------------------------------------------------------------------------- /t/conn/socket.t: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings; 3 | 4 | use Test::More tests => 2; 5 | 6 | use_ok('PocketIO::Socket'); 7 | 8 | my $socket = PocketIO::Socket->new; 9 | ok $socket; 10 | -------------------------------------------------------------------------------- /t/conn/sockets.t: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings; 3 | 4 | use Test::More tests => 2; 5 | 6 | use_ok('PocketIO::Sockets'); 7 | 8 | use PocketIO::Pool; 9 | 10 | my $pool = PocketIO::Pool->new; 11 | 12 | my $sockets = PocketIO::Sockets->new(pool => $pool); 13 | ok $sockets; 14 | 15 | $sockets->send('foo'); 16 | $sockets->emit('bar'); 17 | -------------------------------------------------------------------------------- /t/lib/Handler.pm: -------------------------------------------------------------------------------- 1 | package Handler; 2 | 3 | use strict; 4 | use warnings; 5 | 6 | sub new { 7 | my $class = shift; 8 | 9 | return bless {}, $class; 10 | } 11 | 12 | sub run { 13 | my $self = shift; 14 | 15 | return sub { 16 | }; 17 | } 18 | 19 | 1; 20 | -------------------------------------------------------------------------------- /t/pool.t: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings; 3 | 4 | use Test::More tests => 5; 5 | 6 | use_ok('PocketIO::Pool'); 7 | 8 | my $pool = PocketIO::Pool->new; 9 | 10 | ok !$pool->find_connection(123); 11 | 12 | my $conn; 13 | $pool->add_connection( 14 | sub { 15 | $conn = shift; 16 | } 17 | ); 18 | ok $conn; 19 | 20 | is $conn->id, $pool->find_connection($conn->id)->id; 21 | 22 | $pool->remove_connection($conn->id, sub { }); 23 | 24 | ok !$pool->find_connection($conn->id); 25 | -------------------------------------------------------------------------------- /t/resource.t: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings; 3 | 4 | use Test::More tests => 9; 5 | 6 | use_ok('PocketIO::Resource'); 7 | 8 | use PocketIO::Pool; 9 | 10 | my $pool = PocketIO::Pool->new; 11 | my $d = PocketIO::Resource->new(pool => $pool); 12 | my $cb = sub { }; 13 | 14 | eval { $d->dispatch({REQUEST_METHOD => 'HEAD'}, $cb); }; 15 | ok($@); 16 | 17 | eval { $d->dispatch({REQUEST_METHOD => 'GET', PATH_INFO => '/hello'}, $cb) }; 18 | ok($@); 19 | 20 | $pool = PocketIO::Pool->new; 21 | eval { 22 | PocketIO::Resource->new(pool => $pool) 23 | ->dispatch({REQUEST_METHOD => 'GET', PATH_INFO => '/1/websocket/123'}, 24 | $cb); 25 | }; 26 | ok($@); 27 | 28 | my $res; 29 | my $delayed = 30 | $d->dispatch({REQUEST_METHOD => 'POST', PATH_INFO => '/1/'}, $cb); 31 | $delayed->( 32 | sub { 33 | $res = $_[0]; 34 | } 35 | ); 36 | is $res->[0], 200; 37 | is_deeply $res->[1], 38 | [ 'Content-Type' => 'text/plain', 39 | 'Connection' => 'keep-alive', 40 | 'Content-Length' => 79, 41 | ]; 42 | like $res->[2]->[0], 43 | qr/^\d+:15:25:websocket,flashsocket,htmlfile,xhr-polling,jsonp-polling$/; 44 | 45 | $pool = PocketIO::Pool->new; 46 | $delayed = PocketIO::Resource->new( 47 | pool => $pool, 48 | heartbeat_timeout => 15, 49 | close_timeout => 20 50 | )->dispatch({REQUEST_METHOD => 'POST', PATH_INFO => '/1/'}, $cb); 51 | $delayed->( 52 | sub { 53 | $res = $_[0]; 54 | } 55 | ); 56 | is $res->[0], 200; 57 | like $res->[2]->[0], 58 | qr/^\d+:15:20:websocket,flashsocket,htmlfile,xhr-polling,jsonp-polling$/; 59 | -------------------------------------------------------------------------------- /t/room.t: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings; 3 | 4 | use PocketIO::Pool; 5 | use Test::More tests => 2; 6 | 7 | my $pool = PocketIO::Pool->new; 8 | 9 | ok($pool); 10 | 11 | my $sockets = PocketIO::Sockets->new(pool => $pool); 12 | 13 | { 14 | # monkey patch PocketIO::Pool; 15 | no warnings 'redefine'; 16 | my $message; 17 | local *PocketIO::Pool::send_raw = sub { 18 | my $self = shift; 19 | my %message = @_; 20 | $message = $message{message}; 21 | return $self; 22 | }; 23 | 24 | my $room = $sockets->in('test'); 25 | $room->send({ test => 1 }); 26 | is_deeply($message, { test => 1 }, "Room::send doesn't stringify message"); 27 | } 28 | 29 | -------------------------------------------------------------------------------- /t/transport/htmlfile.t: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings; 3 | 4 | BEGIN { 5 | use Test::More; 6 | 7 | plan skip_all => 'Plack and Twiggy are required to run this test' 8 | unless eval { require Plack; require Twiggy; 1 }; 9 | } 10 | 11 | plan tests => 2; 12 | 13 | use PocketIO::Test; 14 | 15 | use AnyEvent; 16 | use AnyEvent::Impl::Perl; 17 | use AnyEvent::Socket; 18 | use Plack::Builder; 19 | 20 | use PocketIO; 21 | 22 | my $app = builder { 23 | mount '/socket.io' => PocketIO->new( 24 | handler => sub { 25 | my $self = shift; 26 | 27 | ok(1); 28 | } 29 | ); 30 | }; 31 | 32 | my $server = '127.0.0.1'; 33 | 34 | test_pocketio( 35 | $app => sub { 36 | my $port = shift; 37 | 38 | my $session_id = http_get_session_id $server, $port; 39 | 40 | my $cv = AnyEvent->condvar; 41 | $cv->begin; 42 | 43 | tcp_connect $server, $port, sub { 44 | my ($fh) = @_ or return $cv->send; 45 | 46 | syswrite $fh, 47 | join "\x0d\x0a" => 48 | "GET /socket.io/1/htmlfile/$session_id HTTP/1.0", 49 | "Host: $server:$port", 50 | 'Connection: keep-alive', 51 | '', 52 | ''; 53 | 54 | my $buffer = ''; 55 | 56 | my $read_watcher; 57 | $read_watcher = AnyEvent->io( 58 | fh => $fh, 59 | poll => "r", 60 | cb => sub { 61 | my $len = sysread $fh, my $chunk, 1024, 0; 62 | 63 | $buffer .= $chunk; 64 | 65 | if ($buffer 66 | =~ m!\Q\E! 67 | && $buffer =~ m!\Q\E!) 68 | { 69 | undef $read_watcher; 70 | $cv->end; 71 | } 72 | 73 | if ($len <= 0) { 74 | undef $read_watcher; 75 | $cv->end; 76 | } 77 | } 78 | ); 79 | 80 | $cv->begin; 81 | tcp_connect $server, $port, sub { 82 | my ($fh) = @_ or return $cv->send; 83 | 84 | syswrite $fh, 85 | join "\x0d\x0a" => 86 | "POST /socket.io/1/htmlfile/$session_id HTTP/1.0", 87 | "Host: $server:$port", 88 | 'Content-Length: 3', 89 | '', 90 | '2::'; 91 | 92 | my $read_watcher; 93 | $read_watcher = AnyEvent->io( 94 | fh => $fh, 95 | poll => "r", 96 | cb => sub { 97 | my $len = sysread $fh, my $chunk, 1024, 0; 98 | 99 | if ($chunk =~ m/1$/) { 100 | ok(1); 101 | $cv->end; 102 | } 103 | 104 | if ($len <= 0) { 105 | undef $read_watcher; 106 | $cv->end; 107 | } 108 | } 109 | ); 110 | }; 111 | }; 112 | 113 | $cv->wait; 114 | } 115 | ); 116 | -------------------------------------------------------------------------------- /t/transport/jsonp-polling.t: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings; 3 | 4 | BEGIN { 5 | use Test::More; 6 | 7 | plan skip_all => 'Plack and Twiggy are required to run this test' 8 | unless eval { require Plack; require Twiggy; 1 }; 9 | } 10 | 11 | plan tests => 3; 12 | 13 | use PocketIO::Test; 14 | 15 | use AnyEvent; 16 | use AnyEvent::Impl::Perl; 17 | use AnyEvent::Socket; 18 | use Plack::Builder; 19 | 20 | use PocketIO; 21 | 22 | my $app = builder { 23 | mount '/socket.io' => PocketIO->new( 24 | handler => sub { 25 | my $self = shift; 26 | 27 | ok(1); 28 | } 29 | ); 30 | }; 31 | 32 | my $server = '127.0.0.1'; 33 | 34 | test_pocketio( 35 | $app => sub { 36 | my $port = shift; 37 | 38 | my $session_id = http_get_session_id $server, $port; 39 | 40 | my $cv = AnyEvent->condvar; 41 | $cv->begin; 42 | tcp_connect $server, $port, sub { 43 | my ($fh) = @_ or return $cv->send; 44 | 45 | syswrite $fh, <<"EOF"; 46 | GET /socket.io/1/jsonp-polling/$session_id HTTP/1.1 47 | Host: $server:$port 48 | 49 | EOF 50 | 51 | my $read_watcher; 52 | $read_watcher = AnyEvent->io( 53 | fh => $fh, 54 | poll => "r", 55 | cb => sub { 56 | my $len = sysread $fh, my $chunk, 1024, 0; 57 | 58 | if ($chunk =~ m/\Qio.j[0]("1::");\E$/) { 59 | ok(1); 60 | undef $read_watcher; 61 | $cv->end; 62 | } 63 | 64 | if ($len <= 0) { 65 | undef $read_watcher; 66 | $cv->end; 67 | } 68 | } 69 | ); 70 | }; 71 | 72 | $cv->begin; 73 | tcp_connect $server, $port, sub { 74 | my ($fh) = @_ or return $cv->send; 75 | 76 | syswrite $fh, <<"EOF"; 77 | POST /socket.io/1/jsonp-polling/$session_id HTTP/1.1 78 | Host: $server:$port 79 | 80 | d=2%3A%3A 81 | EOF 82 | 83 | my $read_watcher; 84 | $read_watcher = AnyEvent->io( 85 | fh => $fh, 86 | poll => "r", 87 | cb => sub { 88 | my $len = sysread $fh, my $chunk, 1024, 0; 89 | 90 | if ($chunk =~ m/1$/) { 91 | ok(1); 92 | undef $read_watcher; 93 | $cv->end; 94 | } 95 | 96 | if ($len <= 0) { 97 | undef $read_watcher; 98 | $cv->end; 99 | } 100 | } 101 | ); 102 | }; 103 | 104 | $cv->wait; 105 | } 106 | ); 107 | -------------------------------------------------------------------------------- /t/transport/websocket.t: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings; 3 | 4 | BEGIN { 5 | use Test::More; 6 | 7 | plan skip_all => 'Plack and Twiggy are required to run this test' 8 | unless eval { require Plack; require Twiggy; 1 }; 9 | 10 | plan skip_all => 'Hangs on Windows' if $^O eq 'MSWin32'; 11 | } 12 | 13 | plan tests => 2; 14 | 15 | use PocketIO::Test; 16 | 17 | use AnyEvent; 18 | use AnyEvent::Impl::Perl; 19 | use AnyEvent::Socket; 20 | use Plack::Builder; 21 | use Protocol::WebSocket::Frame; 22 | use Protocol::WebSocket::Handshake::Client; 23 | 24 | use PocketIO; 25 | 26 | my $app = builder { 27 | mount '/socket.io' => PocketIO->new( 28 | handler => sub { 29 | my $self = shift; 30 | 31 | ok(1); 32 | 33 | $self->close; 34 | } 35 | ); 36 | }; 37 | 38 | my $server = '127.0.0.1'; 39 | 40 | test_pocketio( 41 | $app => sub { 42 | my $port = shift; 43 | 44 | my $session_id = http_get_session_id $server, $port; 45 | 46 | my $cv = AnyEvent->condvar; 47 | 48 | $cv->begin; 49 | tcp_connect $server, $port, sub { 50 | my ($fh) = @_ or return $cv->send; 51 | 52 | my $hs = Protocol::WebSocket::Handshake::Client->new(url => 53 | "ws://$server:$port/socket.io/1/websocket/$session_id"); 54 | my $frame = Protocol::WebSocket::Frame->new; 55 | 56 | syswrite $fh, $hs->to_string; 57 | 58 | my $read_watcher; 59 | $read_watcher = AnyEvent->io( 60 | fh => $fh, 61 | poll => "r", 62 | cb => sub { 63 | my $len = sysread $fh, my $chunk, 1024, 0; 64 | 65 | $hs->parse($chunk) unless $hs->is_done; 66 | 67 | if ($hs->is_done && length($chunk)) { 68 | $frame->append($chunk); 69 | 70 | if (my $message = $frame->next_bytes) { 71 | is $message, '1::'; 72 | } 73 | } 74 | 75 | if ($len <= 0) { 76 | undef $read_watcher; 77 | $cv->end; 78 | } 79 | } 80 | ); 81 | }; 82 | 83 | $cv->wait; 84 | } 85 | ); 86 | -------------------------------------------------------------------------------- /t/transport/xhr-polling.t: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings; 3 | 4 | BEGIN { 5 | use Test::More; 6 | 7 | plan skip_all => 'Plack and Twiggy are required to run this test' 8 | unless eval { require Plack; require Twiggy; 1 }; 9 | } 10 | 11 | plan tests => 3; 12 | 13 | use PocketIO::Test; 14 | 15 | use AnyEvent; 16 | use AnyEvent::Impl::Perl; 17 | use AnyEvent::Socket; 18 | use Plack::Builder; 19 | 20 | use PocketIO; 21 | 22 | my $app = builder { 23 | mount '/socket.io' => PocketIO->new( 24 | handler => sub { 25 | my $self = shift; 26 | 27 | ok(1); 28 | } 29 | ); 30 | }; 31 | 32 | my $server = '127.0.0.1'; 33 | 34 | test_pocketio( 35 | $app => sub { 36 | my $port = shift; 37 | 38 | my $session_id = http_get_session_id $server, $port; 39 | 40 | my $cv = AnyEvent->condvar; 41 | $cv->begin; 42 | tcp_connect $server, $port, sub { 43 | my ($fh) = @_ or return $cv->send; 44 | 45 | syswrite $fh, <<"EOF"; 46 | GET /socket.io/1/xhr-polling/$session_id HTTP/1.1 47 | Host: $server:$port 48 | 49 | EOF 50 | 51 | my $read_watcher; 52 | $read_watcher = AnyEvent->io( 53 | fh => $fh, 54 | poll => "r", 55 | cb => sub { 56 | my $len = sysread $fh, my $chunk, 1024, 0; 57 | 58 | if ($chunk =~ m/1::/) { 59 | ok(1); 60 | undef $read_watcher; 61 | $cv->end; 62 | } 63 | 64 | if ($len <= 0) { 65 | undef $read_watcher; 66 | $cv->end; 67 | } 68 | } 69 | ); 70 | }; 71 | 72 | $cv->begin; 73 | tcp_connect $server, $port, sub { 74 | my ($fh) = @_ or return $cv->send; 75 | 76 | syswrite $fh, <<"EOF"; 77 | POST /socket.io/1/xhr-polling/$session_id HTTP/1.1 78 | Host: $server:$port 79 | 80 | 2:: 81 | EOF 82 | 83 | my $read_watcher; 84 | $read_watcher = AnyEvent->io( 85 | fh => $fh, 86 | poll => "r", 87 | cb => sub { 88 | my $len = sysread $fh, my $chunk, 1024, 0; 89 | 90 | if ($chunk =~ m/1$/) { 91 | ok(1); 92 | undef $read_watcher; 93 | $cv->end; 94 | } 95 | 96 | if ($len <= 0) { 97 | undef $read_watcher; 98 | $cv->end; 99 | } 100 | } 101 | ); 102 | }; 103 | 104 | $cv->wait; 105 | } 106 | ); 107 | -------------------------------------------------------------------------------- /xt/changes.t: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings; 3 | 4 | use Test::More; 5 | 6 | eval 'use Test::CPAN::Changes'; 7 | 8 | plan skip_all => 'Test::CPAN::Changes required for this test' if $@; 9 | 10 | changes_ok(); 11 | -------------------------------------------------------------------------------- /xt/pod-coverage.t: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings; 3 | 4 | use Test::More; 5 | 6 | # Ensure a recent version of Test::Pod::Coverage 7 | my $min_tpc = 1.08; 8 | eval "use Test::Pod::Coverage $min_tpc"; 9 | plan skip_all => "Test::Pod::Coverage $min_tpc required for testing POD coverage" 10 | if $@; 11 | 12 | # Test::Pod::Coverage doesn't require a minimum Pod::Coverage version, 13 | # but older versions don't recognize some common documentation styles 14 | my $min_pc = 0.18; 15 | eval "use Pod::Coverage $min_pc"; 16 | plan skip_all => "Pod::Coverage $min_pc required for testing POD coverage" 17 | if $@; 18 | 19 | all_pod_coverage_ok(); 20 | -------------------------------------------------------------------------------- /xt/pod.t: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings; 3 | 4 | use Test::More; 5 | 6 | # Ensure a recent version of Test::Pod 7 | my $min_tp = 1.22; 8 | eval "use Test::Pod $min_tp"; 9 | plan skip_all => "Test::Pod $min_tp required for testing POD" if $@; 10 | 11 | all_pod_files_ok(); 12 | --------------------------------------------------------------------------------