perl/bsvf/lib/IO/Unread.pm

   1 package IO::Unread;
   2
   3 use 5.008001;
   4
   5 use warnings;
   6 use strict;
   7
   8 use Carp;
   9 use XSLoader;
  10 use Symbol qw/qualify_to_ref/;
  11 use Scalar::Util qw/openhandle/;
  12
  13 BEGIN {
  14     our $VERSION   = '1.04';
  15     XSLoader::load __PACKAGE__, $VERSION;
  16 }
  17
  18 my $USE_PERLIO = HAVE_PERLIO_LAYERS;
  19 my $Debug;
  20
  21 sub debug {
  22     my $func = (caller 1)[3];
  23     $Debug and warn "$func: ", @_;
  24 }
  25
  26 sub import {
  27     no strict 'refs';
  28     my $from = shift;
  29     my $to   = caller;
  30     my @carp;
  31
  32     while ($_ = shift) {
  33         /^-tie$/ and do {
  34             $USE_PERLIO = 0;
  35             next;
  36         };
  37
  38         /^-debug$/ and do {
  39             $Debug = 1;
  40             debug "debugging on";
  41             next;
  42         };
  43
  44         s/^&//;
  45         !/^_/ and /[^[:upper:]]/ and
  46             exists &{"$from\::$_"} and do
  47         {
  48             *{"$to\::$_"} = \&{"$from\::$_"};
  49             next;
  50         };
  51
  52         push @carp, qq/"$_" is not exported by $from/;
  53     }
  54
  55     @carp and do {
  56         carp $_ for @carp;
  57         croak "can't continue after import errors";
  58     };
  59
  60     debug "import done";
  61 }
  62
  63 sub _get_fh {
  64     my $fh = do {
  65         local $^W = 0;
  66         qualify_to_ref shift, caller 2;
  67     };
  68     openhandle $fh or return;
  69     debug "fh open";
  70     _check_fh $fh  or return;
  71     debug "fh mode good";
  72     return $fh;
  73 }
  74
  75 sub unread (*@) {
  76     {
  77         no warnings 'uninitialized';
  78         debug '[', (join '][', @_), ']';
  79     }
  80
  81     my $fh = _get_fh shift or return;
  82
  83     my $str = @_ ? (join "", reverse @_) : $_;
  84     length $str or return "0 but true";
  85
  86     my $rv;
  87     undef $@;
  88     if ($USE_PERLIO) {
  89         debug "using PerlIO_unread";
  90         $rv = eval { _PerlIO_unread $fh, $str };
  91     }
  92     else {
  93         debug "using IO::Unread::Tied";
  94         tie *$fh, 'IO::Unread::Tied' => $fh, $str;
  95         $rv = length $str;
  96     }
  97
  98     if ($@) {
  99         warnings::enabled "io" and carp $@;
 100         return;
 101     }
 102     defined $rv or return;
 103     $rv         or return "0 but true";
 104     return $rv;
 105 }
 106
 107 sub ungetc (*;$) {
 108     my $fh = _get_fh shift or return;
 109
 110     my $str = @_ ? shift : $_;
 111     length $str or return '';
 112
 113     my $rv = _PerlIO_ungetc $fh, substr $str, 0, 1;
 114     defined $rv or return;
 115     return $rv;
 116 }
 117
 118 {{
 119
 120 package IO::Unread::Tied;
 121
 122 use Tie::Handle 4.0;
 123 use base qw/Tie::Handle/;
 124 use Carp;
 125 BEGIN { *debug = \&IO::Unread::debug }
 126
 127 sub TIEHANDLE {
 128     my ($c, $handle, $data) = @_;
 129     debug $data;
 130     $handle eq 'RETIE' and (debug "retieing"), return $data;
 131     length $data or croak __PACKAGE__."::TIEHANDLE called with null data";
 132     return bless { handle => $handle, data => $data }, $c;
 133 }
 134
 135 sub WRITE {
 136     my ($s, $data, $len, $off) = @_;
 137     debug;
 138     my $h = $s->{handle};
 139     untie *$h;
 140     my $rv = print $h substr $data, 0, $off;
 141     tie *$h, ref $s => RETIE => $s;
 142     return $rv;
 143 }
 144
 145 sub READ {
 146     my ($s, undef, $len, $off) = @_;
 147     my $h    = $s->{handle};
 148     my $rv   = $len;
 149
 150     debug;
 151
 152     my $read = substr $s->{data}, 0, $len, '';
 153     $len -= length $read;
 154     unless (length $s->{data}) {
 155         untie *$h;
 156         $rv = read $h, $read, $len, length $read;
 157         defined $rv and $rv += length $read;
 158     }
 159
 160     substr($_[1], $off, 0) = $read;
 161     return $rv;
 162 }
 163
 164 sub READLINE {
 165     my $s   = shift;
 166     my $h   = $s->{handle};
 167     my $rv;
 168
 169     debug;
 170
 171     if (not defined $/) {
 172         untie *$h;
 173         return $s->{data} . <$h>;
 174     }
 175
 176     if ($/ eq '') {
 177         $rv = $s->{data} =~ s!^ ([^\n]* \n+)!!x;
 178         $rv = $rv ? $1 : undef;
 179     }
 180     else {
 181         $rv = $s->{data} =~ s!^ (.*? \Q$/\E )!!x;
 182         $rv = $rv ? $1 : undef;
 183     }
 184
 185     debug "rv = ", (defined $rv) ? (quotemeta $rv) : "(undef)";
 186
 187     unless (defined $rv) {
 188         $rv = $s->{data};
 189         $s->{data} = '';
 190     }
 191
 192     if ($s->{data} eq '') {
 193         untie *$h;
 194
 195         my $done = $rv =~ m! \Q$/\E $ !x;
 196         if ($/ eq '') {
 197             my $chr = getc $h;
 198             IO::Unread::ungetc $h, $chr;
 199             $done = ($chr ne "\n");
 200         }
 201         debug "rv = |$rv|, \$/ = |$/|, done = $done";
 202         $rv .= <$h> unless $done;
 203     }
 204     debug "rv = $rv";
 205
 206     return $rv;
 207 }
 208
 209 sub CLOSE {
 210     untie *{$_[0]{handle}};
 211     close $_[0]{handle};
 212 }
 213
 214 sub SEEK {
 215     my $s = shift;
 216     untie *{$s->{handle}};
 217     seek $s->{handle}, $_[0], $_[1];
 218 }
 219
 220 sub TELL {
 221     untie *{$_[0]{handle}};
 222     tell $_[0]{handle};
 223 }
 224
 225 sub UNTIE {
 226     debug;
 227 }
 228
 229 }}
 230
 231 42;
 232
 233 =head1 NAME
 234
 235 IO::Unread - push more than one character back onto a filehandle
 236
 237 =head1 SYNOPSIS
 238
 239     use IO::Unread;
 240
 241     unread STDIN, "hello world\n";
 242
 243     $_ = "goodbye";
 244     unread ARGV;
 245
 246 =head1 DESCRIPTION
 247
 248 C<IO::Unread> exports one function, C<unread>, which will push data back
 249 onto a filehandle. Any amount of data can be pushed: if your perl is
 250 built with PerlIO layers, the data is stored in a special C<:pending>
 251 layer; if not, the module C<tie>s the filehandle to a class which
 252 returns the unread data and unties itself.
 253
 254 =head2 unread FILEHANDLE, LIST
 255
 256 C<unread> unreads LIST onto FILEHANDLE. If LIST is omitted, C<$_> is unread.
 257 Returns the number of characters unread on success, C<undef> on failure. Warnings
 258 are produced under category C<io>.
 259
 260 Note that C<unread $FH, 'a', 'b'> is equivalent to
 261
 262   unread $FH, 'a';
 263   unread $FH, 'b';
 264
 265 , ie. to C<unread $FH, 'ba'> rather than C<unread $FH, 'ab'>.
 266
 267 =head2 ungetc FILEHANDLE, STRING
 268
 269 C<ungetc> pushes the first character of STRING onto FILEHANDLE. Unlike
 270 C<unread>, it does not use a C<tie> implementation if your perl doesn't
 271 support PerlIO layers; rather it calls your I<ungetc(3)>. This is only
 272 guarenteed to support one character of pushback, and then only if it is
 273 the last character that was read from the handle.
 274
 275 =head1 EXPORTS
 276
 277 None by default; C<unread>, C<ungetc> on request.
 278
 279 =head1 BUGS
 280
 281 C<ungetc> is subject to the whims of your libc if you're not using
 282 perlio.
 283
 284 =head1 COPYRIGHT
 285
 286 Copyright 2003 Ben Morrow <ben@morrow.me.uk>
 287
 288 This library is free software; you can redistribute it and/or modify
 289 it under the same terms as Perl itself.
 290
 291 =head1 SEE ALSO
 292
 293 L<PerlIO>, L<perltie>, L<ungetc(3)>
 294
 295 =cut