1package IO::Callback; 2 3use warnings; 4use strict; 5 6=head1 NAME 7 8IO::Callback - Emulate file interface for a code reference 9 10=head1 VERSION 11 12Version 1.12 13 14=cut 15 16our $VERSION = '1.12'; 17 18=head1 SYNOPSIS 19 20C<IO::Callback> provides an easy way to produce a phoney read-only filehandle that calls back to your own code when it needs data to satisfy a read. This is useful if you want to use a library module that expects to read data from a filehandle, but you want the data to come from some other source and you don't want to read it all into memory and use L<IO::String>. 21 22 use IO::Callback; 23 24 my $fh = IO::Callback->new('<', sub { ... ; return $data }); 25 my $object = Some::Class->new_from_file($fh); 26 27Similarly, IO::Callback allows you to wrap up a coderef as a write-only filehandle, which you can pass to a library module that expects to write its output to a filehandle. 28 29 my $fh = IO::Callback->new('>', sub { my $data = shift ; ... }); 30 $object->dump_to_file($fh); 31 32 33=head1 CONSTRUCTOR 34 35=head2 C<new ( MODE, CODEREF [,ARG ...] )> 36 37Returns a filehandle object encapsulating the coderef. 38 39MODE must be either C<E<lt>> for a read-only filehandle or C<E<gt>> for a write-only filehandle. 40 41For a read-only filehandle, the callback coderef will be invoked in a scalar context each time more data is required to satisfy a read. It must return some more input data (at least one byte) as a string. If there is no more data to be read, then the callback should return either C<undef> or the empty string. If ARG values were supplied to the constructor, then they will be passed to the callback each time it is invoked. 42 43For a write-only filehandle, the callback will be invoked each time there is data to be written. The first argument will be the data as a string, which will always be at least one byte long. If ARG values were supplied to the constructor, then they will be passed as additional arguments to the callback. When the filehandle is closed, the callback will be invoked once with the empty string as its first argument. 44 45To simulate a non-fatal error on the file, the callback should set C<$!> and return the special value C<IO::Callback::Error>. See examples 6 and 7 below. 46 47=head1 EXAMPLES 48 49=over 4 50 51=item Example 1 52 53To generate a filehandle from which an infinite number of C<x> characters can be read: 54 55=for test "ex1" begin 56 57 my $fh = IO::Callback->new('<', sub {"xxxxxxxxxxxxxxxxxxxxxxxxxxx"}); 58 59 my $x = $fh->getc; # $x now contains "x" 60 read $fh, $x, 5; # $x now contains "xxxxx" 61 62=for test "ex1" end 63 64=item Example 2 65 66A filehandle from which 1000 C<foo> lines can be read before EOF: 67 68=for test "ex2" begin 69 70 my $count = 0; 71 my $fh = IO::Callback->new('<', sub { 72 return if ++$count > 1000; # EOF 73 return "foo\n"; 74 }); 75 76 my $x = <$fh>; # $x now contains "foo\n" 77 read $fh, $x, 2; # $x now contains "fo" 78 read $fh, $x, 2; # $x now contains "o\n" 79 read $fh, $x, 20; # $x now contains "foo\nfoo\nfoo\nfoo\nfoo\n" 80 my @foos = <$fh>; # @foos now contains ("foo\n") x 993 81 82=for test "ex2" end 83 84The example above uses a C<closure> (a special kind of anonymous sub, see L<http://perldoc.perl.org/perlfaq7.html#What's-a-closure?>) to allow the callback to keep track of how many lines it has returned. You don't have to use a closure if you don't want to, since C<IO::Callback> will forward extra constructor arguments to the callback. This example could be re-written as: 85 86=for test "ex2a" begin 87 88 my $count = 0; 89 my $fh = IO::Callback->new('<', \&my_callback, \$count); 90 91 my $x = <$fh>; # $x now contains "foo\n" 92 read $fh, $x, 2; # $x now contains "fo" 93 read $fh, $x, 2; # $x now contains "o\n" 94 read $fh, $x, 20; # $x now contains "foo\nfoo\nfoo\nfoo\nfoo\n" 95 my @foos = <$fh>; # @foos now contains ("foo\n") x 993 96 97 sub my_callback { 98 my $count_ref = shift; 99 100 return if ++$$count_ref > 1000; # EOF 101 return "foo\n"; 102 }; 103 104=for test "ex2a" end 105 106=item Example 3 107 108To generate a filehandle interface to data drawn from an SQL table: 109 110=for test "ex3" begin 111 112 my $sth = $dbh->prepare("SELECT ..."); 113 $sth->execute; 114 my $fh = IO::Callback->new('<', sub { 115 my @row = $sth->fetchrow_array; 116 return unless @row; # EOF 117 return join(',', @row) . "\n"; 118 }); 119 120 # ... 121 122=for test "ex3" end 123 124=item Example 4 125 126You want a filehandle to which data can be written, where the data is discarded but an exception is raised if the data includes the string C<foo>. 127 128=for test "ex4" begin 129 130 my $buf = ''; 131 my $fh = IO::Callback->new('>', sub { 132 $buf .= shift; 133 die "foo written" if $buf =~ /foo/; 134 135 if ($buf =~ /(fo?)\z/) { 136 # Part way through a "foo", carry over to the next block. 137 $buf = $1; 138 } else { 139 $buf = ''; 140 } 141 }); 142 143=for test "ex4" end 144 145=item Example 5 146 147You have been given an object with a copy_data_out() method that takes a destination filehandle as an argument. You don't want the data written to a file though, you want it split into 1024-byte blocks and inserted into an SQL database. 148 149=for test "ex5" begin 150 151 my $blocksize = 1024; 152 my $sth = $dbh->prepare('INSERT ...'); 153 154 my $buf = ''; 155 my $fh = IO::Callback->new('>', sub { 156 $buf .= shift; 157 while (length $buf >= $blocksize) { 158 $sth->execute(substr $buf, 0, $blocksize, ''); 159 } 160 }); 161 162 $thing->copy_data_out($fh); 163 164 if (length $buf) { 165 # There is a remainder of < $blocksize 166 $sth->execute($buf); 167 } 168 169=for test "ex5" end 170 171=item Example 6 172 173You're testing some code that reads data from a file, you want to check that it behaves as expected if it gets an IO error part way through the file. 174 175=for test "ex6" begin 176 177 use IO::Callback; 178 use Errno qw/EIO/; 179 180 my $block1 = "x" x 10240; 181 my $block2 = "y" x 10240; 182 my @blocks = ($block1, $block2); 183 184 my $fh = IO::Callback->new('<', sub { 185 return shift @blocks if @blocks; 186 $! = EIO; 187 return IO::Callback::Error; 188 }); 189 190 # ... 191 192=for test "ex6" end 193 194=item Example 7 195 196You're testing some code that writes data to a file handle, you want to check that it behaves as expected if it gets a C<file system full> error after it has written the first 100k of data. 197 198=for test "ex7" begin 199 200 use IO::Callback; 201 use Errno qw/ENOSPC/; 202 203 my $wrote = 0; 204 my $fh = IO::Callback->new('>', sub { 205 $wrote += length $_[0]; 206 if ($wrote > 100_000) { 207 $! = ENOSPC; 208 return IO::Callback::Error; 209 } 210 }); 211 212 # ... 213 214=for test "ex7" end 215 216=back 217 218=cut 219 220use Carp; 221use Errno qw/EBADF/; 222use IO::String; 223use base qw/IO::String/; 224 225sub open 226{ 227 my $self = shift; 228 return $self->new(@_) unless ref($self); 229 230 my $mode = shift or croak "mode missing in IO::Callback::new"; 231 if ($mode eq '<') { 232 *$self->{R} = 1; 233 } elsif ($mode eq '>') { 234 *$self->{W} = 1; 235 } else { 236 croak qq{invalid mode "$mode" in IO::Callback::new}; 237 } 238 239 my $code = shift or croak "coderef missing in IO::Callback::new"; 240 ref $code eq "CODE" or croak "non-coderef second argument in IO::Callback::new"; 241 242 my $buf = ''; 243 *$self->{Buf} = \$buf; 244 *$self->{Pos} = 0; 245 *$self->{Err} = 0; 246 *$self->{lno} = 0; 247 248 if (@_) { 249 my @args = @_; 250 *$self->{Code} = sub { $code->(@_, @args) }; 251 } else { 252 *$self->{Code} = $code; 253 } 254} 255 256sub close 257{ 258 my $self = shift; 259 return unless defined *$self->{Code}; 260 return if *$self->{Err}; 261 if (*$self->{W}) { 262 my $ret = *$self->{Code}(''); 263 if ($ret and ref $ret eq 'IO::Callback::ErrorMarker') { 264 *$self->{Err} = 1; 265 return; 266 } 267 } 268 foreach my $key (qw/Code Buf Eof R W Pos lno/) { 269 delete *$self->{$key}; 270 } 271 *$self->{Err} = -1; 272 undef *$self if $] eq "5.008"; # cargo culted from IO::String 273 return 1; 274} 275 276sub opened 277{ 278 my $self = shift; 279 return defined *$self->{R} || defined *$self->{W}; 280} 281 282sub getc 283{ 284 my $self = shift; 285 *$self->{R} or return $self->_ebadf; 286 my $buf; 287 return $buf if $self->read($buf, 1); 288 return undef; 289} 290 291sub ungetc 292{ 293 my ($self, $char) = @_; 294 *$self->{R} or return $self->_ebadf; 295 my $buf = *$self->{Buf}; 296 $$buf = chr($char) . $$buf; 297 --*$self->{Pos}; 298 delete *$self->{Eof}; 299 return 1; 300} 301 302sub eof 303{ 304 my $self = shift; 305 return *$self->{Eof}; 306} 307 308# Use something very distinctive for the error return code, since write callbacks 309# may pay no attention to what they are returning, and it would be bad to mistake 310# returned noise for an error indication. 311sub Error () { 312 return bless {}, 'IO::Callback::ErrorMarker'; 313} 314 315sub _doread { 316 my $self = shift; 317 318 return unless *$self->{Code}; 319 my $newbit = *$self->{Code}(); 320 if (defined $newbit) { 321 if (ref $newbit) { 322 if (ref $newbit eq 'IO::Callback::ErrorMarker') { 323 *$self->{Err} = 1; 324 return; 325 } else { 326 confess "unexpected reference type ".ref($newbit)." returned by callback"; 327 } 328 } 329 if (length $newbit) { 330 ${*$self->{Buf}} .= $newbit; 331 return 1; 332 } 333 } 334 335 # fall-through for both undef and '' 336 delete *$self->{Code}; 337 return; 338} 339 340sub getline 341{ 342 my $self = shift; 343 344 *$self->{R} or return $self->_ebadf; 345 return if *$self->{Eof} || *$self->{Err}; 346 my $buf = *$self->{Buf}; 347 $. = *$self->{lno}; 348 349 unless (defined $/) { # slurp 350 1 while $self->_doread; 351 return if *$self->{Err}; 352 *$self->{Pos} += length $$buf; 353 *$self->{Eof} = 1; 354 *$self->{Buf} = \(my $newbuf = ''); 355 $. = ++ *$self->{lno}; 356 return $$buf; 357 } 358 359 my $rs = length $/ ? $/ : "\n\n"; 360 for (;;) { 361 # In paragraph mode, discard extra newlines. 362 if ($/ eq '' and $$buf =~ s/^(\n+)//) { 363 *$self->{Pos} += length $1; 364 } 365 my $pos = index $$buf, $rs; 366 if ($pos >= 0) { 367 *$self->{Pos} += $pos+length($rs); 368 my $ret = substr $$buf, 0, $pos+length($rs), ''; 369 unless (length $/) { 370 # paragraph mode, discard extra trailing newlines 371 $$buf =~ s/^(\n+)// and *$self->{Pos} += length $1; 372 while (*$self->{Code} and length $$buf == 0) { 373 $self->_doread; 374 return if *$self->{Err}; 375 $$buf =~ s/^(\n+)// and *$self->{Pos} += length $1; 376 } 377 } 378 $self->_doread while *$self->{Code} and length $$buf == 0 and not *$self->{Err}; 379 if (length $$buf == 0 and not *$self->{Code}) { 380 *$self->{Eof} = 1; 381 } 382 $. = ++ *$self->{lno}; 383 return $ret; 384 } 385 if (*$self->{Code}) { 386 $self->_doread; 387 return if *$self->{Err}; 388 } else { 389 # EOL not in buffer and no more data to come - the last line is missing its EOL. 390 *$self->{Eof} = 1; 391 *$self->{Pos} += length $$buf; 392 *$self->{Buf} = \(my $newbuf = ''); 393 $. = ++ *$self->{lno} if length $$buf; 394 return $$buf if length $$buf; 395 return; 396 } 397 } 398} 399 400sub getlines 401{ 402 croak "getlines() called in scalar context" unless wantarray; 403 my $self = shift; 404 405 *$self->{R} or return $self->_ebadf; 406 return if *$self->{Err} || *$self->{Eof}; 407 408 # To exactly match Perl's behavior on real files, getlines() should not 409 # increment $. if there is no more input, but getline() should. I won't 410 # call getline() until I've established that there is more input. 411 my $buf = *$self->{Buf}; 412 unless (length $$buf) { 413 $self->_doread; 414 return unless length $$buf; 415 } 416 417 my($line, @lines); 418 push(@lines, $line) while defined($line = $self->getline); 419 return @lines; 420} 421 422sub READLINE 423{ 424 goto &getlines if wantarray; 425 goto &getline; 426} 427 428sub read 429{ 430 my $self = shift; 431 432 *$self->{R} or return $self->_ebadf; 433 my $len = $_[1]||0; 434 435 croak "Negative length" if $len < 0; 436 return if *$self->{Err}; 437 return 0 if *$self->{Eof}; 438 my $buf = *$self->{Buf}; 439 440 1 while *$self->{Code} and $len > length $$buf and $self->_doread; 441 return if *$self->{Err}; 442 if ($len > length $$buf) { 443 $len = length $$buf; 444 *$self->{Eof} = 1 unless $len; 445 } 446 447 if (@_ > 2) { # read offset 448 my $offset = $_[2]||0; 449 if ($offset < -1 * length $_[0]) { 450 croak "Offset outside string"; 451 } 452 if ($offset > length $_[0]) { 453 $_[0] .= "\0" x ($offset - length $_[0]); 454 } 455 substr($_[0], $offset) = substr($$buf, 0, $len, ''); 456 } 457 else { 458 $_[0] = substr($$buf, 0, $len, ''); 459 } 460 *$self->{Pos} += $len; 461 return $len; 462} 463 464*sysread = \&read; 465*syswrite = \&write; 466 467sub stat { 468 my $self = shift; 469 return unless $self->opened; 470 return 1 unless wantarray; 471 472 my @stat = $self->SUPER::stat(); 473 474 # size unknown, report 0 475 $stat[7] = 0; 476 $stat[12] = 1; 477 478 return @stat; 479} 480 481sub print 482{ 483 my $self = shift; 484 485 my $result; 486 if (defined $\) { 487 if (defined $,) { 488 $result = $self->write(join($,, @_).$\); 489 } 490 else { 491 $result = $self->write(join("",@_).$\); 492 } 493 } 494 else { 495 if (defined $,) { 496 $result = $self->write(join($,, @_)); 497 } 498 else { 499 $result = $self->write(join("",@_)); 500 } 501 } 502 503 return unless defined $result; 504 return 1; 505} 506*printflush = \*print; 507 508sub printf 509{ 510 my $self = shift; 511 my $fmt = shift; 512 my $result = $self->write(sprintf($fmt, @_)); 513 return unless defined $result; 514 return 1; 515} 516 517sub getpos 518{ 519 my $self = shift; 520 521 $. = *$self->{lno}; 522 return *$self->{Pos}; 523} 524*tell = \&getpos; 525*pos = \&getpos; 526 527sub setpos 528{ 529 croak "setpos not implemented for IO::Callback"; 530} 531 532sub truncate 533{ 534 croak "truncate not implemented for IO::Callback"; 535} 536 537sub seek 538{ 539 croak "Illegal seek"; 540} 541*sysseek = \&seek; 542 543sub write 544{ 545 my $self = shift; 546 547 *$self->{W} or return $self->_ebadf; 548 return if *$self->{Err}; 549 550 my $slen = length($_[0]); 551 my $len = $slen; 552 my $off = 0; 553 if (@_ > 1) { 554 my $xlen = defined $_[1] ? $_[1] : 0; 555 $len = $xlen if $xlen < $len; 556 croak "Negative length" if $len < 0; 557 if (@_ > 2) { 558 $off = $_[2] || 0; 559 if ( $off >= $slen and $off > 0 and ($] < 5.011 or $off > $slen) ) { 560 croak "Offset outside string"; 561 } 562 if ($off < 0) { 563 $off += $slen; 564 croak "Offset outside string" if $off < 0; 565 } 566 my $rem = $slen - $off; 567 $len = $rem if $rem < $len; 568 } 569 } 570 return $len if $len == 0; 571 my $ret = *$self->{Code}(substr $_[0], $off, $len); 572 if (defined $ret and ref $ret eq 'IO::Callback::ErrorMarker') { 573 *$self->{Err} = 1; 574 return; 575 } 576 *$self->{Pos} += $len; 577 return $len; 578} 579 580sub error { 581 my $self = shift; 582 583 return *$self->{Err}; 584} 585 586sub clearerr { 587 my $self = shift; 588 589 *$self->{Err} = 0; 590} 591 592sub _ebadf { 593 my $self = shift; 594 595 $! = EBADF; 596 *$self->{Err} = -1; 597 return; 598} 599 600*GETC = \&getc; 601*PRINT = \&print; 602*PRINTF = \&printf; 603*READ = \&read; 604*WRITE = \&write; 605*SEEK = \&seek; 606*TELL = \&getpos; 607*EOF = \&eof; 608*CLOSE = \&close; 609 610=head1 AUTHOR 611 612Dave Taylor, C<< <dave.taylor.cpan at gmail.com> >> 613 614=head1 BUGS AND LIMITATIONS 615 616Fails to inter-operate with some library modules that read or write filehandles from within XS code. I am aware of the following specific cases, please let me know if you run into any others: 617 618=over 4 619 620=item C<Digest::MD5::addfile()> 621 622=back 623 624Please report any other bugs or feature requests to C<bug- at rt.cpan.org>, or through 625the web interface at L<http://rt.cpan.org/NoAuth/ReportBug.html?Queue=IO::Callback>. I will be notified, and then you'll 626automatically be notified of progress on your bug as I make changes. 627 628=head1 SUPPORT 629 630You can find documentation for this module with the perldoc command. 631 632 perldoc IO::Callback 633 634You can also look for information at: 635 636=over 4 637 638=item * RT: CPAN's request tracker 639 640L<http://rt.cpan.org/NoAuth/Bugs.html?Dist=IO::Callback> 641 642=item * AnnoCPAN: Annotated CPAN documentation 643 644L<http://annocpan.org/dist/IO::Callback> 645 646=item * CPAN Ratings 647 648L<http://cpanratings.perl.org/d/IO::Callback> 649 650=item * Search CPAN 651 652L<http://search.cpan.org/dist/IO::Callback> 653 654=back 655 656=head1 SEE ALSO 657 658L<IO::String>, L<IO::Stringy>, L<perlfunc/open> 659 660=head1 ACKNOWLEDGEMENTS 661 662Adapted from code in L<IO::String> by Gisle Aas. 663 664=head1 MANITAINER 665 666This module is currently being maintained by Toby Inkster (TOBYINK) 667for bug fixes. No substantial changes or new features are planned. 668 669=head1 COPYRIGHT & LICENSE 670 671Copyright 1998-2005 Gisle Aas. 672 673Copyright 2009-2010 Dave Taylor. 674 675This program is free software; you can redistribute it and/or modify it 676under the same terms as Perl itself. 677 678=cut 679 6801; # End of IO::Callback 681