This file is indexed.

/usr/share/perl5/IO/Multiplex.pm is in libio-multiplex-perl 1.16-1.

This file is owned by root:root, with mode 0o644.

The actual contents of the file can be viewed below.

   1
   2
   3
   4
   5
   6
   7
   8
   9
  10
  11
  12
  13
  14
  15
  16
  17
  18
  19
  20
  21
  22
  23
  24
  25
  26
  27
  28
  29
  30
  31
  32
  33
  34
  35
  36
  37
  38
  39
  40
  41
  42
  43
  44
  45
  46
  47
  48
  49
  50
  51
  52
  53
  54
  55
  56
  57
  58
  59
  60
  61
  62
  63
  64
  65
  66
  67
  68
  69
  70
  71
  72
  73
  74
  75
  76
  77
  78
  79
  80
  81
  82
  83
  84
  85
  86
  87
  88
  89
  90
  91
  92
  93
  94
  95
  96
  97
  98
  99
 100
 101
 102
 103
 104
 105
 106
 107
 108
 109
 110
 111
 112
 113
 114
 115
 116
 117
 118
 119
 120
 121
 122
 123
 124
 125
 126
 127
 128
 129
 130
 131
 132
 133
 134
 135
 136
 137
 138
 139
 140
 141
 142
 143
 144
 145
 146
 147
 148
 149
 150
 151
 152
 153
 154
 155
 156
 157
 158
 159
 160
 161
 162
 163
 164
 165
 166
 167
 168
 169
 170
 171
 172
 173
 174
 175
 176
 177
 178
 179
 180
 181
 182
 183
 184
 185
 186
 187
 188
 189
 190
 191
 192
 193
 194
 195
 196
 197
 198
 199
 200
 201
 202
 203
 204
 205
 206
 207
 208
 209
 210
 211
 212
 213
 214
 215
 216
 217
 218
 219
 220
 221
 222
 223
 224
 225
 226
 227
 228
 229
 230
 231
 232
 233
 234
 235
 236
 237
 238
 239
 240
 241
 242
 243
 244
 245
 246
 247
 248
 249
 250
 251
 252
 253
 254
 255
 256
 257
 258
 259
 260
 261
 262
 263
 264
 265
 266
 267
 268
 269
 270
 271
 272
 273
 274
 275
 276
 277
 278
 279
 280
 281
 282
 283
 284
 285
 286
 287
 288
 289
 290
 291
 292
 293
 294
 295
 296
 297
 298
 299
 300
 301
 302
 303
 304
 305
 306
 307
 308
 309
 310
 311
 312
 313
 314
 315
 316
 317
 318
 319
 320
 321
 322
 323
 324
 325
 326
 327
 328
 329
 330
 331
 332
 333
 334
 335
 336
 337
 338
 339
 340
 341
 342
 343
 344
 345
 346
 347
 348
 349
 350
 351
 352
 353
 354
 355
 356
 357
 358
 359
 360
 361
 362
 363
 364
 365
 366
 367
 368
 369
 370
 371
 372
 373
 374
 375
 376
 377
 378
 379
 380
 381
 382
 383
 384
 385
 386
 387
 388
 389
 390
 391
 392
 393
 394
 395
 396
 397
 398
 399
 400
 401
 402
 403
 404
 405
 406
 407
 408
 409
 410
 411
 412
 413
 414
 415
 416
 417
 418
 419
 420
 421
 422
 423
 424
 425
 426
 427
 428
 429
 430
 431
 432
 433
 434
 435
 436
 437
 438
 439
 440
 441
 442
 443
 444
 445
 446
 447
 448
 449
 450
 451
 452
 453
 454
 455
 456
 457
 458
 459
 460
 461
 462
 463
 464
 465
 466
 467
 468
 469
 470
 471
 472
 473
 474
 475
 476
 477
 478
 479
 480
 481
 482
 483
 484
 485
 486
 487
 488
 489
 490
 491
 492
 493
 494
 495
 496
 497
 498
 499
 500
 501
 502
 503
 504
 505
 506
 507
 508
 509
 510
 511
 512
 513
 514
 515
 516
 517
 518
 519
 520
 521
 522
 523
 524
 525
 526
 527
 528
 529
 530
 531
 532
 533
 534
 535
 536
 537
 538
 539
 540
 541
 542
 543
 544
 545
 546
 547
 548
 549
 550
 551
 552
 553
 554
 555
 556
 557
 558
 559
 560
 561
 562
 563
 564
 565
 566
 567
 568
 569
 570
 571
 572
 573
 574
 575
 576
 577
 578
 579
 580
 581
 582
 583
 584
 585
 586
 587
 588
 589
 590
 591
 592
 593
 594
 595
 596
 597
 598
 599
 600
 601
 602
 603
 604
 605
 606
 607
 608
 609
 610
 611
 612
 613
 614
 615
 616
 617
 618
 619
 620
 621
 622
 623
 624
 625
 626
 627
 628
 629
 630
 631
 632
 633
 634
 635
 636
 637
 638
 639
 640
 641
 642
 643
 644
 645
 646
 647
 648
 649
 650
 651
 652
 653
 654
 655
 656
 657
 658
 659
 660
 661
 662
 663
 664
 665
 666
 667
 668
 669
 670
 671
 672
 673
 674
 675
 676
 677
 678
 679
 680
 681
 682
 683
 684
 685
 686
 687
 688
 689
 690
 691
 692
 693
 694
 695
 696
 697
 698
 699
 700
 701
 702
 703
 704
 705
 706
 707
 708
 709
 710
 711
 712
 713
 714
 715
 716
 717
 718
 719
 720
 721
 722
 723
 724
 725
 726
 727
 728
 729
 730
 731
 732
 733
 734
 735
 736
 737
 738
 739
 740
 741
 742
 743
 744
 745
 746
 747
 748
 749
 750
 751
 752
 753
 754
 755
 756
 757
 758
 759
 760
 761
 762
 763
 764
 765
 766
 767
 768
 769
 770
 771
 772
 773
 774
 775
 776
 777
 778
 779
 780
 781
 782
 783
 784
 785
 786
 787
 788
 789
 790
 791
 792
 793
 794
 795
 796
 797
 798
 799
 800
 801
 802
 803
 804
 805
 806
 807
 808
 809
 810
 811
 812
 813
 814
 815
 816
 817
 818
 819
 820
 821
 822
 823
 824
 825
 826
 827
 828
 829
 830
 831
 832
 833
 834
 835
 836
 837
 838
 839
 840
 841
 842
 843
 844
 845
 846
 847
 848
 849
 850
 851
 852
 853
 854
 855
 856
 857
 858
 859
 860
 861
 862
 863
 864
 865
 866
 867
 868
 869
 870
 871
 872
 873
 874
 875
 876
 877
 878
 879
 880
 881
 882
 883
 884
 885
 886
 887
 888
 889
 890
 891
 892
 893
 894
 895
 896
 897
 898
 899
 900
 901
 902
 903
 904
 905
 906
 907
 908
 909
 910
 911
 912
 913
 914
 915
 916
 917
 918
 919
 920
 921
 922
 923
 924
 925
 926
 927
 928
 929
 930
 931
 932
 933
 934
 935
 936
 937
 938
 939
 940
 941
 942
 943
 944
 945
 946
 947
 948
 949
 950
 951
 952
 953
 954
 955
 956
 957
 958
 959
 960
 961
 962
 963
 964
 965
 966
 967
 968
 969
 970
 971
 972
 973
 974
 975
 976
 977
 978
 979
 980
 981
 982
 983
 984
 985
 986
 987
 988
 989
 990
 991
 992
 993
 994
 995
 996
 997
 998
 999
1000
1001
1002
1003
1004
1005
1006
1007
1008
1009
1010
1011
1012
1013
1014
1015
1016
1017
1018
1019
1020
1021
1022
1023
1024
1025
1026
1027
1028
1029
1030
1031
1032
1033
1034
1035
1036
1037
1038
1039
1040
1041
1042
1043
1044
1045
1046
1047
1048
1049
1050
1051
1052
1053
1054
1055
1056
1057
1058
1059
1060
1061
1062
1063
1064
1065
1066
1067
1068
1069
1070
1071
1072
1073
1074
1075
1076
1077
1078
1079
1080
1081
1082
1083
1084
1085
1086
1087
1088
1089
1090
1091
1092
1093
1094
1095
1096
1097
1098
1099
1100
1101
1102
1103
1104
1105
1106
1107
1108
1109
1110
1111
1112
1113
package IO::Multiplex;

use strict;
use warnings;

our $VERSION = '1.16';

=head1 NAME

IO::Multiplex - Manage IO on many file handles

=head1 SYNOPSIS

  use IO::Multiplex;

  my $mux = new IO::Multiplex;
  $mux->add($fh1);
  $mux->add(\*FH2);
  $mux->set_callback_object(...);
  $mux->listen($server_socket);
  $mux->loop;

  sub mux_input { ... }

C<IO::Multiplex> is designed to take the effort out of managing
multiple file handles. It is essentially a really fancy front end to
the C<select> system call. In addition to maintaining the C<select>
loop, it buffers all input and output to/from the file handles.  It
can also accept incoming connections on one or more listen sockets.

=head1 DESCRIPTION

It is object oriented in design, and will notify you of significant events
by calling methods on an object that you supply.  If you are not using
objects, you can simply supply C<__PACKAGE__> instead of an object reference.

You may have one callback object registered for each file handle, or
one global one.  Possibly both -- the per-file handle callback object
will be used instead of the global one.

Each file handle may also have a timer associated with it.  A callback
function is called when the timer expires.

=head2 Handling input on descriptors

When input arrives on a file handle, the C<mux_input> method is called
on the appropriate callback object.  This method is passed three
arguments (in addition to the object reference itself of course):

=over 4

=item 1

a reference to the mux,

=item 2

A reference to the file handle, and

=item 3

a reference to the input buffer for the file handle.

=back

The method should remove the data that it has consumed from the
reference supplied.  It may leave unconsumed data in the input buffer.

=head2 Handling output to descriptors

If C<IO::Multiplex> did not handle output to the file handles as well
as input from them, then there is a chance that the program could
block while attempting to write.  If you let the multiplexer buffer
the output, it will write the data only when the file handle is
capable of receiveing it.

The basic method for handing output to the multiplexer is the C<write>
method, which simply takes a file descriptor and the data to be
written, like this:

    $mux->write($fh, "Some data");

For convenience, when the file handle is C<add>ed to the multiplexer, it
is tied to a special class which intercepts all attempts to write to the
file handle.  Thus, you can use print and printf to send output to the
handle in a normal manner:

    printf $fh "%s%d%X", $foo, $bar, $baz

Unfortunately, Perl support for tied file handles is incomplete, and
functions such as C<send> cannot be supported.

Also, file handle object methods such as the C<send> method of
C<IO::Socket> cannot be intercepted.

=head1 EXAMPLES

=head2 Simple Example

This is a simple telnet-like program, which demonstrates the concepts
covered so far.  It does not really work too well against a telnet
server, but it does OK against the sample server presented further down.

    use IO::Socket;
    use IO::Multiplex;

    # Create a multiplex object
    my $mux  = new IO::Multiplex;
    # Connect to the host/port specified on the command line,
    # or localhost:23
    my $sock = new IO::Socket::INET(Proto    => 'tcp',
                                    PeerAddr => shift || 'localhost',
                                    PeerPort => shift || 23)
        or die "socket: $@";

    # add the relevant file handles to the mux
    $mux->add($sock);
    $mux->add(\*STDIN);
    # We want to buffer output to the terminal.  This prevents the program
    # from blocking if the user hits CTRL-S for example.
    $mux->add(\*STDOUT);

    # We're not object oriented, so just request callbacks to the
    # current package
    $mux->set_callback_object(__PACKAGE__);

    # Enter the main mux loop.
    $mux->loop;

    # mux_input is called when input is available on one of
    # the descriptors.
    sub mux_input {
        my $package = shift;
        my $mux     = shift;
        my $fh      = shift;
        my $input   = shift;

        # Figure out whence the input came, and send it on to the
        # other place.
        if ($fh == $sock) {
            print STDOUT $$input;
        } else {
            print $sock $$input;
        }
        # Remove the input from the input buffer.
        $$input = '';
    }

    # This gets called if the other end closes the connection.
    sub mux_close {
        print STDERR "Connection Closed\n";
        exit;
    }

=head2 A server example

Servers are just as simple to write.  We just register a listen socket
with the multiplex object C<listen> method.  It will automatically
accept connections on it and add them to its list of active file handles.

This example is a simple chat server.

    use IO::Socket;
    use IO::Multiplex;

    my $mux  = new IO::Multiplex;

    # Create a listening socket
    my $sock = new IO::Socket::INET(Proto     => 'tcp',
                                    LocalPort => shift || 2300,
                                    Listen    => 4)
        or die "socket: $@";

    # We use the listen method instead of the add method.
    $mux->listen($sock);

    $mux->set_callback_object(__PACKAGE__);
    $mux->loop;

    sub mux_input {
        my $package = shift;
        my $mux     = shift;
        my $fh      = shift;
        my $input   = shift;

        # The handles method returns a list of references to handles which
        # we have registered, except for listen sockets.
        foreach $c ($mux->handles) {
            print $c $$input;
        }
        $$input = '';
    }

=head2 A more complex server example

Let us take a look at the beginnings of a multi-user game server.  We will
have a Player object for each player.

    # Paste the above example in here, up to but not including the
    # mux_input subroutine.

    # mux_connection is called when a new connection is accepted.
    sub mux_connection {
        my $package = shift;
        my $mux     = shift;
        my $fh      = shift;

        # Construct a new player object
        Player->new($mux, $fh);
    }

    package Player;

    my %players = ();

    sub new {
        my $package = shift;
        my $self    = bless { mux  => shift,
                              fh   => shift } => $package;

        # Register the new player object as the callback specifically for
        # this file handle.

        $self->{mux}->set_callback_object($self, $self->{fh});
        print $self->{fh}
            "Greetings, Professor.  Would you like to play a game?\n";

        # Register this player object in the main list of players
        $players{$self} = $self;
        $mux->set_timeout($self->{fh}, 1);
    }

    sub players { return values %players; }

    sub mux_input {
        my $self = shift;
        shift; shift;         # These two args are boring
        my $input = shift;    # Scalar reference to the input

        # Process each line in the input, leaving partial lines
        # in the input buffer
        while ($$input =~ s/^(.*?)\n//) {
            $self->process_command($1);
        }
    }

    sub mux_close {
       my $self = shift;

       # Player disconnected;
       # [Notify other players or something...]
       delete $players{$self};
    }
    # This gets called every second to update player info, etc...
    sub mux_timeout {
        my $self = shift;
        my $mux  = shift;

        $self->heartbeat;
        $mux->set_timeout($self->{fh}, 1);
    }

=head1 METHODS

=cut

use POSIX qw(errno_h BUFSIZ);
use Socket;
use FileHandle qw(autoflush);
use IO::Handle;
use Fcntl;
use Carp qw(carp);
use constant IsWin => ($^O eq 'MSWin32');


BEGIN {
    eval {
        # Can optionally use Hi Res timers if available
        require Time::HiRes;
        Time::HiRes->import('time');
    };
}

# This is what you want.  Trust me.
$SIG{PIPE} = 'IGNORE';

{   no warnings;
    if(IsWin) { *EWOULDBLOCK = sub() {10035} }
}

=head2 new

Construct a new C<IO::Multiplex> object.

    $mux = new IO::Multiplex;

=cut

sub new
{
    my $package = shift;
    my $self = bless { _readers     => '',
                       _writers     => '',
                       _fhs         => {},
                       _handles     => {},
                       _timerkeys   => {},
                       _timers      => [],
                       _listen      => {}  } => $package;
    return $self;
}

=head2 listen

Add a socket to be listened on.  The socket should have had the
C<bind> and C<listen> system calls already applied to it.  The C<IO::Socket>
module will do this for you.

    $socket = new IO::Socket::INET(Listen => ..., LocalAddr => ...);
    $mux->listen($socket);

Connections will be automatically accepted and C<add>ed to the multiplex
object.  C<The mux_connection> callback method will also be called.

=cut

sub listen
{
    my $self = shift;
    my $fh   = shift;

    $self->add($fh);
    $self->{_fhs}{"$fh"}{listen} = 1;
    $fh;
}

=head2 add

Add a file handle to the multiplexer.

    $mux->add($fh);

As a side effect, this sets non-blocking mode on the handle, and disables
STDIO buffering.  It also ties it to intercept output to the handle.

=cut

sub add
{
    my $self = shift;
    my $fh   = shift;

    return if $self->{_fhs}{"$fh"};

    nonblock($fh);
    autoflush($fh, 1);
    fd_set($self->{_readers}, $fh, 1);

    my $sockopt = getsockopt $fh, SOL_SOCKET, SO_TYPE;
    $self->{_fhs}{"$fh"}{udp_true} = 1
        if defined $sockopt && SOCK_DGRAM == unpack "i", $sockopt;

    $self->{_fhs}{"$fh"}{inbuffer} = '';
    $self->{_fhs}{"$fh"}{outbuffer} = '';
    $self->{_fhs}{"$fh"}{fileno} = fileno($fh);
    $self->{_handles}{"$fh"} = $fh;
    tie *$fh, "IO::Multiplex::Handle", $self, $fh;
    return $fh;
}

=head2 remove

Removes a file handle from the multiplexer.  This also unties the
handle.  It does not currently turn STDIO buffering back on, or turn
off non-blocking mode.

    $mux->remove($fh);

=cut

sub remove
{
    my $self = shift;
    my $fh   = shift;
    fd_set($self->{_writers}, $fh, 0);
    fd_set($self->{_readers}, $fh, 0);
    delete $self->{_fhs}{"$fh"};
    delete $self->{_handles}{"$fh"};
    $self->_removeTimer($fh);
    untie *$fh;
    return 1;
}

=head2 set_callback_object

Set the object on which callbacks are made.  If you are not using objects,
you can specify the name of the package into which the method calls are
to be made.

If a file handle is supplied, the callback object is specific for that
handle:

    $mux->set_callback_object($object, $fh);

Otherwise, it is considered a default callback object, and is used when
events occur on a file handle that does not have its own callback object.

    $mux->set_callback_object(__PACKAGE__);

The previously registered object (if any) is returned.

See also the CALLBACK INTERFACE section.

=cut

sub set_callback_object
{
    my $self = shift;
    my $obj  = shift;
    my $fh   = shift;
    return if $fh && !exists($self->{_fhs}{"$fh"});

    my $old  = $fh ? $self->{_fhs}{"$fh"}{object} : $self->{_object};

    $fh ? $self->{_fhs}{"$fh"}{object} : $self->{_object} = $obj;
    return $old;
}

=head2 kill_output

Remove any pending output on a file descriptor.

    $mux->kill_output($fh);

=cut

sub kill_output
{
    my $self = shift;
    my $fh   = shift;
    return unless $fh && exists($self->{_fhs}{"$fh"});

    $self->{_fhs}{"$fh"}{outbuffer} = '';
    fd_set($self->{_writers}, $fh, 0);
}

=head2 outbuffer

Return or set the output buffer for a descriptor

    $output = $mux->outbuffer($fh);
    $mux->outbuffer($fh, $output);

=cut

sub outbuffer
{
    my $self = shift;
    my $fh   = shift;
    return unless $fh && exists($self->{_fhs}{"$fh"});

    if (@_) {
        $self->{_fhs}{"$fh"}{outbuffer} = $_[0] if @_;
        fd_set($self->{_writers}, $fh, 0) if !$_[0];
    }

    $self->{_fhs}{"$fh"}{outbuffer};
}

=head2 inbuffer

Return or set the input buffer for a descriptor

    $input = $mux->inbuffer($fh);
    $mux->inbuffer($fh, $input);

=cut

sub inbuffer
{
    my $self = shift;
    my $fh   = shift;
    return unless $fh && exists($self->{_fhs}{"$fh"});

    if (@_) {
        $self->{_fhs}{"$fh"}{inbuffer} = $_[0] if @_;
    }

    return $self->{_fhs}{"$fh"}{inbuffer};
}

=head2 set_timeout

Set the timer for a file handle.  The timeout value is a certain number of
seconds in the future, after which the C<mux_timeout> callback is called.

If the C<Time::HiRes> module is installed, the timers may be specified in
fractions of a second.

Timers are not reset automatically.

    $mux->set_timeout($fh, 23.6);

Use C<$mux-E<gt>set_timeout($fh, undef)> to cancel a timer.

=cut

sub set_timeout
{
    my $self     = shift;
    my $fh       = shift;
    my $timeout  = shift;
    return unless $fh && exists($self->{_fhs}{"$fh"});

    if (defined $timeout) {
        $self->_addTimer($fh, $timeout + time);
    } else {
        $self->_removeTimer($fh);
    }
}

=head2 handles

Returns a list of handles that the C<IO::Multiplex> object knows about,
excluding listen sockets.

    @handles = $mux->handles;

=cut

sub handles
{
    my $self = shift;

    return grep(!$self->{_fhs}{"$_"}{listen}, values %{$self->{_handles}});
}

sub _addTimer {
    my $self = shift;
    my $fh   = shift;
    my $time = shift;

    # Set a key so that we can quickly tell if a given $fh has
    # a timer set
    $self->{_timerkeys}{"$fh"} = 1;

    # Store the timeout in an array, and resort it
    @{$self->{_timers}} = sort { $a->[1] <=> $b->[1] } (@{$self->{_timers}}, [ $fh, $time ] );
}

sub _removeTimer {
    my $self = shift;
    my $fh   = shift;

    # Return quickly if no timer is set
    return unless exists $self->{_timerkeys}{"$fh"};

    # Remove the timeout from the sorted array
    @{$self->{_timers}} = grep { $_->[0] ne $fh } @{$self->{_timers}};

    # Get rid of the key
    delete $self->{_timerkeys}{"$fh"};
}


=head2 loop

Enter the main loop and start processing IO events.

    $mux->loop;

=cut

sub loop
{
    my $self = shift;
    my $heartbeat = shift;
    $self->{_endloop} = 0;

    while (!$self->{_endloop} && keys %{$self->{_fhs}}) {
        my $rv;
        my $data;
        my $rdready = "";
        my $wrready = "";
        my $timeout = undef;

        foreach my $fh (values %{$self->{_handles}}) {
            fd_set($rdready, $fh, 1) if
                ref($fh) =~ /SSL/ &&
                $fh->can("pending") &&
                $fh->pending;
        }

        if (!length $rdready) {
            if (@{$self->{_timers}}) {
                $timeout = $self->{_timers}[0][1] - time;
            }

            my $numready = select($rdready=$self->{_readers},
                                  $wrready=$self->{_writers},
                                  undef,
                                  $timeout);

            unless(defined($numready)) {
                if ($! == EINTR || $! == EAGAIN) {
                    next;
                } else {
                    last;
                }
            }
        }

        &{ $heartbeat } ($rdready, $wrready) if $heartbeat;

        foreach my $k (keys %{$self->{_handles}}) {
            my $fh = $self->{_handles}->{$k} or next;

            # Avoid creating a permanent empty hash ref for "$fh"
            # by attempting to access its {object} element
            # if it has already been closed.
            next unless exists $self->{_fhs}{"$fh"};

            # It is not easy to replace $self->{_fhs}{"$fh"} with a
            # variable, because some mux_* routines may remove it as
            # side-effect.

            # Get the callback object.
            my $obj = $self->{_fhs}{"$fh"}{object} ||
                $self->{_object};

            # Is this descriptor ready for reading?
            if (fd_isset($rdready, $fh))
            {
                if ($self->{_fhs}{"$fh"}{listen}) {
                    # It's a server socket, so a new connection is
                    # waiting to be accepted
                    my $client = $fh->accept;
                    next unless ($client);
                    $self->add($client);
                    $obj->mux_connection($self, $client)
                        if $obj && $obj->can("mux_connection");
                } else {
                    if ($self->is_udp($fh)) {
                        $rv = recv($fh, $data, BUFSIZ, 0);
                        if (defined $rv) {
                            # Remember where the last UDP packet came from
                            $self->{_fhs}{"$fh"}{udp_peer} = $rv;
                        }
                    } else {
                        $rv = &POSIX::read(fileno($fh), $data, BUFSIZ);
                    }

                    if (defined($rv) && length($data)) {
                        # Append the data to the client's receive buffer,
                        # and call process_input to see if anything needs to
                        # be done.
                        $self->{_fhs}{"$fh"}{inbuffer} .= $data;
                        $obj->mux_input($self, $fh,
                                        \$self->{_fhs}{"$fh"}{inbuffer})
                            if $obj && $obj->can("mux_input");
                    } else {
                        unless (defined $rv) {
                            next if
                                $! == EINTR ||
                                $! == EAGAIN ||
                                $! == EWOULDBLOCK;
			    warn "IO::Multiplex read error: $!"
                                if $! != ECONNRESET;
                        }
                        # There's an error, or we received EOF.  If
                        # there's pending data to be written, we leave
                        # the connection open so it can be sent.  If
                        # the other end is closed for writing, the
                        # send will error and we close down there.
                        # Either way, we remove it from _readers as
                        # we're no longer interested in reading from
                        # it.
                        fd_set($self->{_readers}, $fh, 0);
                        $obj->mux_eof($self, $fh,
                                      \$self->{_fhs}{"$fh"}{inbuffer})
                            if $obj && $obj->can("mux_eof");

                        if (exists $self->{_fhs}{"$fh"}) {
                            $self->{_fhs}{"$fh"}{inbuffer} = '';
                            # The mux_eof handler could have responded
                            # with a shutdown for writing.
                            $self->close($fh)
                                unless exists $self->{_fhs}{"$fh"}
                                    && length $self->{_fhs}{"$fh"}{outbuffer};
                        }
                        next;
                    }
                }
            }  # end if readable
            next unless exists $self->{_fhs}{"$fh"};

            if (fd_isset($wrready, $fh)) {
                unless (length $self->{_fhs}{"$fh"}{outbuffer}) {
                    fd_set($self->{_writers}, $fh, 0);
                    $obj->mux_outbuffer_empty($self, $fh)
                        if ($obj && $obj->can("mux_outbuffer_empty"));
                    next;
                }
                $rv = &POSIX::write(fileno($fh),
                                    $self->{_fhs}{"$fh"}{outbuffer},
                                    length($self->{_fhs}{"$fh"}{outbuffer}));
                unless (defined($rv)) {
                    # We got an error writing to it.  If it's
                    # EWOULDBLOCK (shouldn't happen if select told us
                    # we can write) or EAGAIN, or EINTR we don't worry
                    # about it.  otherwise, close it down.
                    unless ($! == EWOULDBLOCK ||
                            $! == EINTR ||
                            $! == EAGAIN) {
                        if ($! == EPIPE) {
                            $obj->mux_epipe($self, $fh)
                                if $obj && $obj->can("mux_epipe");
                        } else {
                            warn "IO::Multiplex: write error: $!\n";
                        }
                        $self->close($fh);
                    }
                    next;
                }
                substr($self->{_fhs}{"$fh"}{outbuffer}, 0, $rv) = '';
                unless (length $self->{_fhs}{"$fh"}{outbuffer}) {
                    # Mark us as not writable if there's nothing more to
                    # write
                    fd_set($self->{_writers}, $fh, 0);
                    $obj->mux_outbuffer_empty($self, $fh)
                        if ($obj && $obj->can("mux_outbuffer_empty"));

                    if (   $self->{_fhs}{"$fh"}
                        && $self->{_fhs}{"$fh"}{shutdown}) {
                        # If we've been marked for shutdown after write
                        # do it.
                        shutdown($fh, 1);
                        $self->{_fhs}{"$fh"}{outbuffer} = '';
                        unless (length $self->{_fhs}{"$fh"}{inbuffer}) {
                            # We'd previously been shutdown for reading
                            # also, so close out completely
                            $self->close($fh);
                            next;
                        }
                    }
                }
            }  # End if writeable

            next unless exists $self->{_fhs}{"$fh"};

        }  # End foreach $fh (...)

        $self->_checkTimeouts() if @{$self->{_timers}};

    } # End while(loop)
}

sub _checkTimeouts {
    my $self = shift;

    # Get the current time
    my $time = time;

    # Copy all of the timers that should go off into
    # a temporary array. This allows us to modify the
    # real array as we process the timers, without
    # interfering with the loop.

    my @timers = ();
    foreach my $timer (@{$self->{_timers}}) {
        # If the timer is in the future, we can stop
        last if $timer->[1] > $time;
        push @timers, $timer;
    }

    foreach my $timer (@timers) {
        my $fh = $timer->[0];
        $self->_removeTimer($fh);

        next unless exists $self->{_fhs}{"$fh"};

        my $obj = $self->{_fhs}{"$fh"}{object} || $self->{_object};
        $obj->mux_timeout($self, $fh) if $obj && $obj->can("mux_timeout");
    }
}


=head2 endloop

Prematurly terminate the loop.  The loop will automatically terminate
when there are no remaining descriptors to be watched.

    $mux->endloop;

=cut

sub endloop
{
    my $self = shift;
    $self->{_endloop} = 1;
}

=head2 udp_peer

Get peer endpoint of where the last udp packet originated.

    $saddr = $mux->udp_peer($fh);

=cut

sub udp_peer {
  my $self = shift;
  my $fh = shift;
  return $self->{_fhs}{"$fh"}{udp_peer};
}

=head2 is_udp

Sometimes UDP packets require special attention.
This method will tell if a file handle is of type UDP.

    $is_udp = $mux->is_udp($fh);

=cut

sub is_udp {
  my $self = shift;
  my $fh = shift;
  return $self->{_fhs}{"$fh"}{udp_true};
}

=head2 write

Send output to a file handle.

    $mux->write($fh, "'ere I am, JH!\n");

=cut

sub write
{
    my $self = shift;
    my $fh   = shift;
    my $data = shift;
    return unless $fh && exists($self->{_fhs}{"$fh"});

    if ($self->{_fhs}{"$fh"}{shutdown}) {
        $! = EPIPE;
        return undef;
    }
    if ($self->is_udp($fh)) {
        if (my $udp_peer = $self->udp_peer($fh)) {
            # Send the packet back to the last peer that said something
            return send($fh, $data, 0, $udp_peer);
        } else {
            # No udp_peer yet?
            # This better be a connect()ed UDP socket
            # or else this will fail with ENOTCONN
            return send($fh, $data, 0);
        }
    }
    $self->{_fhs}{"$fh"}{outbuffer} .= $data;
    fd_set($self->{_writers}, $fh, 1);
    return length($data);
}

=head2 shutdown

Shut down a socket for reading or writing or both.  See the C<shutdown>
Perl documentation for further details.

If the shutdown is for reading, it happens immediately.  However,
shutdowns for writing are delayed until any pending output has been
successfully written to the socket.

    $mux->shutdown($socket, 1);

=cut

sub shutdown
{
    my $self = shift;
    my $fh = shift;
    my $which = shift;
    return unless $fh && exists($self->{_fhs}{"$fh"});

    if ($which == 0 || $which == 2) {
        # Shutdown for reading.  We can do this now.
        shutdown($fh, 0);
        # The mux_eof hook must be run from the main loop to consume
        # the rest of the inbuffer if there is anything left.
        # It will also remove $fh from _readers.
    }

    if ($which == 1 || $which == 2) {
        # Shutdown for writing.  Only do this now if there is no pending
        # data.
        if(length $self->{_fhs}{"$fh"}{outbuffer}) {
            $self->{_fhs}{"$fh"}{shutdown} = 1;
        } else {
            shutdown($fh, 1);
            $self->{_fhs}{"$fh"}{outbuffer} = '';
        }
    }
    # Delete the descriptor if it's totally gone.
    unless (length $self->{_fhs}{"$fh"}{inbuffer} ||
            length $self->{_fhs}{"$fh"}{outbuffer}) {
        $self->close($fh);
    }
}

=head2 close

Close a handle.  Always use this method to close a handle that is being
watched by the multiplexer.

    $mux->close($fh);

=cut

sub close
{
    my $self = shift;
    my $fh = shift;
    return unless exists $self->{_fhs}{"$fh"};

    my $obj = $self->{_fhs}{"$fh"}{object} || $self->{_object};
    warn "closing with read buffer"  if length $self->{_fhs}{"$fh"}{inbuffer};
    warn "closing with write buffer" if length $self->{_fhs}{"$fh"}{outbuffer};

    fd_set($self->{_readers}, $fh, 0);
    fd_set($self->{_writers}, $fh, 0);

    delete $self->{_fhs}{"$fh"};
    delete $self->{_handles}{"$fh"};
    untie *$fh;
    close $fh;
    $obj->mux_close($self, $fh) if $obj && $obj->can("mux_close");
}

# We set non-blocking mode on all descriptors.  If we don't, then send
# might block if the data is larger than the kernel can accept all at once,
# even though select told us we can write.  With non-blocking mode, we
# get a partial write in those circumstances, which is what we want.

sub nonblock
{   my $fh = shift;

    if(IsWin)
    {   ioctl($fh, 0x8004667e, pack("L!", 1));
    }
    else
    {   my $flags = fcntl($fh, F_GETFL, 0)
            or die "fcntl F_GETFL: $!\n";
        fcntl($fh, F_SETFL, $flags | O_NONBLOCK)
            or die "fcntl F_SETFL $!\n";
    }
}

sub fd_set
{
     vec($_[0], fileno($_[1]), 1) = $_[2];
}

sub fd_isset
{
    return vec($_[0], fileno($_[1]), 1);
}

# We tie handles into this package to handle write buffering.

package IO::Multiplex::Handle;

use strict;
use Tie::Handle;
use Carp;
use vars qw(@ISA);
@ISA = qw(Tie::Handle);

sub FILENO
{
    my $self = shift;
    return ($self->{_mux}->{_fhs}->{"$self->{_fh}"}->{fileno});
}


sub TIEHANDLE
{
    my $package = shift;
    my $mux = shift;
    my $fh  = shift;

    my $self = bless { _mux   => $mux,
                       _fh    => $fh } => $package;
    return $self;
}

sub WRITE
{
    my $self = shift;
    my ($msg, $len, $offset) = @_;
    $offset ||= 0;
    return $self->{_mux}->write($self->{_fh}, substr($msg, $offset, $len));
}

sub CLOSE
{
    my $self = shift;
    return $self->{_mux}->shutdown($self->{_fh}, 2);
}

sub READ
{
    carp "Do not read from a muxed file handle";
}

sub READLINE
{
    carp "Do not read from a muxed file handle";
}

sub FETCH
{
    return "Fnord";
}

sub UNTIE {}

1;

__END__

=head1 CALLBACK INTERFACE

Callback objects should support the following interface.  You do not have
to provide all of these methods, just provide the ones you are interested in.

All methods receive a reference to the callback object (or package) as
their first argument, in the traditional object oriented
way. References to the C<IO::Multiplex> object and the relevant file
handle are also provided.  This will be assumed in the method
descriptions.

=head2 mux_input

Called when input is ready on a descriptor.  It is passed a reference to
the input buffer.  It should remove any input that it has consumed, and
leave any partially received data in the buffer.

    sub mux_input {
        my $self = shift;
        my $mux  = shift;
        my $fh   = shift;
        my $data = shift;

        # Process each line in the input, leaving partial lines
        # in the input buffer
        while ($$data =~ s/^(.*?\n)//) {
            $self->process_command($1);
        }
    }

=head2 mux_eof

This is called when an end-of-file condition is present on the descriptor.
This is does not nessecarily mean that the descriptor has been closed, as
the other end of a socket could have used C<shutdown> to close just half
of the socket, leaving us free to write data back down the still open
half.  Like mux_input, it is also passed a reference to the input buffer.
It should consume the entire buffer or else it will just be lost.

In this example, we send a final reply to the other end of the socket,
and then shut it down for writing.  Since it is also shut down for reading
(implicly by the EOF condition), it will be closed once the output has
been sent, after which the mux_close callback will be called.

    sub mux_eof {
        my $self = shift;
        my $mux  = shift;
        my $fh   = shift;

        print $fh "Well, goodbye then!\n";
        $mux->shutdown($fh, 1);
    }

=head2 mux_close

Called when a handle has been completely closed.  At the time that
C<mux_close> is called, the handle will have been removed from the
multiplexer, and untied.

=head2 mux_outbuffer_empty

Called after all pending output has been written to the file descriptor.

=head2 mux_connection

Called upon a new connection being accepted on a listen socket.

=head2 mux_timeout

Called when a timer expires.

=head1 AUTHOR

Copyright 1999 Bruce J Keeler <bruce@gridpoint.com>

Copyright 2001-2008 Rob Brown <bbb@cpan.org>

Released under the same terms as Perl itself.

$Id: Multiplex.pm,v 1.45 2015/04/09 21:27:54 rob Exp $

=cut