Re: [MacPerl] MacPerl bugs?

[Chris Nandor <pudge@pobox.com>]

At 21.59 -0400 1999.06.25, Chris Nandor wrote:
>It differs from binmode() in that binmode() gets applied to a specific
>filehandle.  Doing that here would not solve the whole problem anyway,
>because chomp() has nothing to do with filehandles.  Here's another idea,
>though: there could be a tied filehandle to translate every thing to local
>newline on read, without touching $/ (well, only internal to the tied class
>with dynamic scoping).  I have a prototype for it, but it would need a lot
>of details worked out and discussed to decide on how each function would
>behave.

Here is a go at a tied class to handle newlines in the background.  Calling
textmode(*HANDLE) will find out what newline the file uses, then tie the
handle, blessing an array of the FH and the NL character(s).  The only
functions that really work here are close(), getc(), read(), and readline()
(as well as <>, which is implemented via readline()).  For some reason,
readline() requires you to pass a glob, while the others do not:

  #!perl -w
  use strict;
  use IO::Handle::Newline;

  open FOO, "<dosfile" or die $!;
  textmode(*FOO);  # this should not require a glob either :/
  print scalar <FOO>;
  print scalar readline *FOO;  # i don't know if this is fixed in 5.005 yet
  for (0..19) { print getc(FOO) }
  print getc(FOO);
  read(FOO, my($b), 12);
  print $b;
  close FOO;

Anyway, this passes on NT (under Virtual PC) with ActivePerl 517 and
LinuxPPC 5.0 with perl5.005_03.  If anyone thinks it may be useful, please
play with it and let me know how well it does or doesn't work, and I can
iron out problems and put it on CPAN.

Suggestions for a different name for the module are welcome, too.

package IO::Handle::Newline;
# pudge@pobox.com, Friday, June 25, 1999 and Friday, July 2, 1999

# convert newlines to LF on all inputs (READ, GETC, READLINE)
# does nothing for outputs, so use only on RDONLY files
# probably will add support for writing to RDWR files

require Exporter;
use strict;
use vars qw(@ISA @EXPORT $NL @EXPORT_OK);
@ISA = 'Exporter';
@EXPORT = 'textmode';
@EXPORT_OK = 'set_newline';

$NL = "\n";
sub FH ()       { 0 }
sub NL ()       { 1 }
sub LEN ()      { 2 }
sub FIRST ()    { 3 }

sub set_newline { $NL = shift }

sub textmode (*) {
    my $fh = $_[0];
    binmode($fh);
    my $nl;
    my $pos = tell $fh;
    seek $fh, 0, 0 or return;
    until ($nl) {
        read $fh, my($bytes), 1024 or return;
        ($nl) = ($bytes =~ /(\015?\012|\015)$/);
    }
    seek $fh, $pos, 0 or return;
    tie *$fh, __PACKAGE__, *$fh, $nl;
}

sub TIEHANDLE {
    my($pkg, $fh, $nl) = @_;
    bless [$fh, $nl, length($nl), substr($nl, 0, 1)];
}

sub READLINE {
    my $fh = shift;
    my $nl = $fh->[NL];
    local $/ = ($/ && $/ eq "\n" ? $nl : $/);
    my @lines = wantarray ? readline $fh->[FH] : scalar readline $fh->[FH];
    return unless defined $lines[0];
    for (@lines) {
        s|$nl|$NL|g;
    }
    return wantarray ? @lines : $lines[0];
}

sub GETC {
    my $fh = shift;
    my $nl = $fh->[NL];
    local $/ = ($/ && $/ eq "\n" ? $nl : $/);
    my $c = getc $fh->[FH];
    return unless defined $c;
    if ($fh->[LEN] > 1 && $c eq $fh->[FIRST]) {
        if (read $fh->[FH], my $b, 1) {
            if ($c . $b eq $nl) {
                $c .= $b;
            } else {
                seek $fh->[FH], -1, 1;
            }
        }
    }
    $c =~ s|$nl|$NL|;
    return $c;
}

sub READ {
    my($fh, $len, $off, $buf) = (@_[0, 2, 4], \$_[1]);
    my $nl = $fh->[NL];
    local $/ = ($/ && $/ eq "\n" ? $nl : $/);
    (defined $off ?
        read($fh->[FH], $$buf, $len, $off) :
        read($fh->[FH], $$buf, $len)) or return;

    BLOCK: {
        if ($nl ne $NL) {
            while ($$buf =~ s|$nl|$NL|g) {
                for (1 .. ($fh->[LEN] - 1)) {
                    read($fh->[FH], my($b), 1);
                    $$buf .= $b;
                }
            }
        }

        if (length($nl) > 1 && substr($$buf, -1, 1) eq $fh->[FIRST]) {
            my($b, $c);
            for (1 .. (length($nl) - 1)) {
                $c += read($fh->[FH], $b, 1);
            }
            if ($b && ($fh->[FIRST] . $b) eq $nl) {
                $$buf .= $b;
                redo;
            } else {
                seek $fh->[FH], -$c, 1;
            }
        }
    }

    while (length($$buf) > $len) {
        chop $$buf;
        seek $fh->[FH], -1, 1;
    }

    return length $$buf;
}

sub PRINT {
    my $fh = shift->[FH];
    print $fh @_;
}

sub PRINTF {
    my $fh = shift->[FH];
    my $format = shift;
    print $fh $format, @_;
}

sub WRITE {
    my $fh = shift->[FH];
    write $fh;
}

sub CLOSE {
    my $fh = $_[0];
    close $fh->[FH];
}

1;

__END__

Here is a test script:

#!perl -w
use diagnostics;
use strict;
use vars qw($loaded $c);
# Before `make install' is performed this script should be runnable with
# `make test'. After `make install' it should work as `perl test.pl'

######################### We start with some black magic to print on failure.

# Change 1..1 below to 1..last_test_to_print .
# (It may become useful if the test is moved to ./t subdirectory.)

BEGIN { $| = 1; print "1..13\n"; }
END {print "not ok 1\n" unless $loaded;}
use lib 'lib', 'blib';
use IO::Handle::Newline;
$loaded = 1;
printf "ok %d\n", ++$c;

######################### End of black magic.

# Insert your test code below (better if it prints "ok 13"
# (correspondingly "not ok 13") depending on the success of chunk 13
# of the test code):

my $text = <<EOT;
hello

old friend
how are ya doin'?


EOT

local $\;

(my $textCRLF = $text) =~ s/\n/\015\012/g;
(my $textLF = $text) =~ s/\n/\012/g;
(my $textCR = $text) =~ s/\n/\015/g;

open CRLF, "> textCRLF" or die "Can't open textCRLF: $!";
open LF, "> textLF" or die "Can't open textLF: $!";
open CR, "> textCR" or die "Can't open textCR: $!";

binmode CRLF;
binmode LF;
binmode CR;

print CRLF $textCRLF;
print LF $textLF;
print CR $textCR;

close CRLF or die "Can't close textCRLF: $!";
close LF or die "Can't close textLF: $!";
close CR or die "Can't close textCR: $!";

open CRLF, "< textCRLF" or die "Can't open textCRLF: $!";
open LF, "< textLF" or die "Can't open textLF: $!";
open CR, "< textCR" or die "Can't open textCR: $!";

textmode *CRLF;
textmode *LF;
textmode *CR;

{
    local $/;
    ok(<CRLF> eq $text);
    ok(<LF> eq $text);
    ok(<CR> eq $text);
}

seek CRLF, 0, 0;
seek LF, 0, 0;
seek CR, 0, 0;

ok(read(CRLF, my($b_crlf), 7) == 7);
ok(read(LF, my($b_lf), 7) == 7);
ok(read(CR, my($b_cr), 7) == 7);

ok($b_crlf eq "hello\n\n");
ok($b_lf eq "hello\n\n");
ok($b_cr eq "hello\n\n");

ok(getc(CRLF) eq 'o');
ok(getc(LF) eq 'o');
ok(getc(CR) eq 'o');

close CRLF or die "Can't close textCRLF: $!";
close LF or die "Can't close textLF: $!";
close CR or die "Can't close textCR: $!";

unlink "textCRLF" or die "Can't unlink textCRLF: $!";
unlink "textLF" or die "Can't unlink textLF: $!";
unlink "textCR" or die "Can't unlink textCR: $!";

sub ok { printf "%sok %d\n", ($_[0] ? '' : 'not '), ++$c }

__END__

--
Chris Nandor          mailto:pudge@pobox.com         http://pudge.net/
%PGPKey = ('B76E72AD', [1024, '0824090B CE73CA10  1FF77F13 8180B6B6'])

===== Want to unsubscribe from this list?
===== Send mail with body "unsubscribe" to macperl-request@macperl.org