summaryrefslogtreecommitdiff
path: root/Master/tlpkg/tlperl/lib/Tk/Event/IO.pm
diff options
context:
space:
mode:
Diffstat (limited to 'Master/tlpkg/tlperl/lib/Tk/Event/IO.pm')
-rw-r--r--Master/tlpkg/tlperl/lib/Tk/Event/IO.pm132
1 files changed, 132 insertions, 0 deletions
diff --git a/Master/tlpkg/tlperl/lib/Tk/Event/IO.pm b/Master/tlpkg/tlperl/lib/Tk/Event/IO.pm
new file mode 100644
index 00000000000..3cd2fda3856
--- /dev/null
+++ b/Master/tlpkg/tlperl/lib/Tk/Event/IO.pm
@@ -0,0 +1,132 @@
+package Tk::Event::IO;
+use strict;
+use Carp;
+
+use vars qw($VERSION @EXPORT_OK);
+$VERSION = '4.009'; # sprintf '4.%03d', q$Revision: #8 $ =~ /\D(\d+)\s*$/;
+
+use base qw(Exporter);
+use Symbol ();
+
+@EXPORT_OK = qw(READABLE WRITABLE);
+
+sub PrintArgs
+{
+ my $func = (caller(1))[3];
+ print "$func(",join(',',@_),")\n";
+}
+
+sub PRINT
+{
+ my $obj = shift;
+ $obj->wait(WRITABLE);
+ my $h = $obj->handle;
+ return print $h @_;
+}
+
+sub PRINTF
+{
+ my $obj = shift;
+ $obj->wait(WRITABLE);
+ my $h = $obj->handle;
+ return printf $h @_;
+}
+
+sub WRITE
+{
+ my $obj = $_[0];
+ $obj->wait(WRITABLE);
+ return syswrite($obj->handle,$_[1],$_[2]);
+}
+
+my $depth = 0;
+sub READLINE
+{
+ my $obj = shift;
+ $obj->wait(READABLE);
+ my $h = $obj->handle;
+ my $w = <$h>;
+ return $w;
+}
+
+sub READ
+{
+ my $obj = $_[0];
+ $obj->wait(READABLE);
+ my $h = $obj->handle;
+ return sysread($h,$_[1],$_[2],defined $_[3] ? $_[3] : 0);
+}
+
+sub GETC
+{
+ my $obj = $_[0];
+ $obj->wait(READABLE);
+ my $h = $obj->handle;
+ return getc($h);
+}
+
+sub CLOSE
+{
+ my $obj = shift;
+ $obj->unwatch;
+ my $h = $obj->handle;
+ return close($h);
+}
+
+sub EOF
+{
+ my $obj = shift;
+ my $h = $obj->handle;
+ return eof($h);
+}
+
+sub FILENO
+{
+ my $obj = shift;
+ my $h = $obj->handle;
+ return fileno($h);
+}
+
+sub imode
+{
+ my $mode = shift;
+ my $imode = ${{'readable' => READABLE(),
+ 'writable' => WRITABLE()}}{$mode};
+ croak("Invalid handler type '$mode'") unless (defined $imode);
+ return $imode;
+}
+
+sub fileevent
+{
+ my ($widget,$file,$mode,$cb) = @_;
+ my $imode = imode($mode);
+ unless (ref $file)
+ {
+ no strict 'refs';
+ $file = Symbol::qualify($file,(caller)[0]);
+ $file = \*{$file};
+ }
+ my $obj = tied(*$file);
+ unless ($obj && $obj->isa('Tk::Event::IO'))
+ {
+ $obj = tie *$file,'Tk::Event::IO', $file;
+ }
+ if (@_ == 3)
+ {
+ # query return the handler
+ return $obj->handler($imode);
+ }
+ else
+ {
+ # set the handler
+ my $h = $obj->handler($imode,$cb);
+ undef $obj; # Prevent warnings about untie with ref to object
+ unless ($h)
+ {
+ untie *$file;
+ }
+ }
+}
+
+1;
+__END__