The Perl and Raku Conference 2025: Greenville, South Carolina - June 27-29 Learn more

NI-S / Tk-b12 / HTML / HTML / IO.pm 

            

              
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

              
package LWP::IO;
# $Id: TkIO.pm,v 1.3 1995/12/29 15:12:04 aas Exp $
require Tk;
require LWP::Debug;
use MIME::QuotedPrint qw(encode_qp);
=head1 NAME
LWP::TkIO - Tk I/O routines for the LWP library
=head1 SYNOPSIS
 use Tk;
 require LWP::TkIO;
 require LWP::UserAgent;
=head1 DESCRIPTION
This module provide replacement functions for the LWP::IO
functions. Require this module if you use Tk and want non exclusive IO
behaviour from LWP.
See also L<LWP::IO>.
=cut
sub read
{
    my $fd = shift;
    my $dataRef = \$_[0];
    my $size    =  $_[1];
    my $offset  =  $_[2] || 0;
    my $timeout =  $_[3];
    my $doneFlag = 0;
    my $n;
    my $timer;
    my $timeoutSub = sub { undef $timer };
    Tk->fileevent($fd, 'readable',
                  sub {
                       $n = sysread($fd, $$dataRef, 1, $offset);
                  #     print STDERR fileno($fd)," sz=$size off=$offset n=$n:$!\n";
                       if (defined $n)
                        {
                        #LWP::Debug::conns("Read $n bytes: '" .
                        #               encode_qp(substr($$dataRef, $offset, $n)) .
                        #               "'");
                         $offset += $n;
                        }
                        $doneFlag = 1;
                      }
                 );
    $timer = Tk->after($timeout*1000, $timeoutSub );
    Tk::DoOneEvent(0) until ($doneFlag || !defined($timer));
    Tk->fileevent($fd, 'readable', ''); # no more callbacks
    die "Timeout" unless (defined $timer);
    Tk->after(cancel => $timer);
    return $n;
}
sub write
{
    my $fd = shift;
    my $dataRef = \$_[0];
    my $timeout =  $_[1];
    my $len = length $$dataRef;
    return 0 unless $len;
    my $offset = 0;
    my $timeoutFlag = 0;
    my $doneFlag = 0;
    my $timeoutSub = sub { $timeoutFlag = 1; };
    my $timer;
    $timer = Tk->after($timeout*1000, $timeoutSub ) if $timeout;
    Tk->fileevent($fd, 'writable',
                  sub {
                      my $n = syswrite($fd, $$dataRef, $len-$offset, $offset);
                      if (!defined $n) {
                          $done = 1;
                      } else {
                          LWP::Debug::conns("Write $n bytes: '" .
                                            substr($$dataRef, $offset, $n) .
                                            "'");
                          $offset += $n;
                          $timer = Tk->after($timeout*1000, $timeoutSub )
                            if $timeout;
                      }
                  }
                 );
    Tk::DoOneEvent(0) until ($timeoutFlag || $doneFlag || $offset >= $len);
    Tk->fileevent($fd, 'writable', ''); # no more callbacks
    Tk->after(cancel => $timer) if $timeout;
    die "Timeout" if $timeoutFlag;
    $offset;
}
1;