clc-intercal 1:1.0~4pre1.-94.-2-2 / usr / share / perl5 / Language / INTERCAL / GenericIO.pm

package Language::INTERCAL::GenericIO;

# Write/read data

# This file is part of CLC-INTERCAL

# Copyright (c) 2006-2008 Claudio Calvelli, all rights reserved.

# CLC-INTERCAL is copyrighted software. However, permission to use, modify,
# and distribute it is granted provided that the conditions set out in the
# licence agreement are met. See files README and COPYING in the distribution.

use strict;
use vars qw($VERSION $PERVERSION);
($VERSION) = ($PERVERSION = "CLC-INTERCAL/Base INTERCAL/GenericIO.pm 1.-94.-2") =~ /\s(\S+)$/;

use Carp;
use IO::File;
use Language::INTERCAL::Exporter '1.-94.-2';
use Language::INTERCAL::Charset '1.-94.-2', qw(toascii fromascii);
use Language::INTERCAL::Splats '1.-94.-2', qw(:SP);
use vars qw(@EXPORT @EXPORT_OK @EXPORT_TAGS
	    $stdread $stdwrite $stdsplat $devnull);
@EXPORT = ();
@EXPORT_OK = qw($stdread $stdwrite $stdsplat $devnull);
@EXPORT_TAGS = (files => [qw($stdread $stdwrite $stdsplat $devnull)]);

$stdread = new Language::INTERCAL::GenericIO('FILE', 'r', '-');
$stdwrite = new Language::INTERCAL::GenericIO('FILE', 'w', '-');
$stdsplat = new Language::INTERCAL::GenericIO('FILE', 'r', '-2');
$devnull = new Language::INTERCAL::GenericIO('TEE', 'r', []);

sub new {
    @_ >= 3
	or croak "Usage: new Language::INTERCAL::GenericIO(TYPE, MODE, DATA)";
    my ($class, $type, $mode, @data) = @_;
    if ($mode =~ /^\d+$/) {
	$mode = chr($mode & 0xff) . ($mode & 0x100 ? '+' : '');
    }
    $mode =~ /^[rwau]\+?$/ or faint(SP_IOMODE, $mode);
    $type = uc($type);
    my $module = "Language::INTERCAL::GenericIO::$type";
    eval "use $module";
    die $@ if $@;
    my $object = bless {
	type => $type,
	mode => $mode,
	data => \@data,
	read_convert => sub { shift },
	read_charset => 'ASCII',
	write_convert => sub { shift },
	write_unconvert => sub { shift },
	write_charset => 'ASCII',
	text_newline => "\n",
	exported => 0,
	buffer => '',
    }, $module;
    $object->_new($mode, @data);
    $object;
}

# methods which subclasses must override
sub tell { faint(SP_SEEKERR, "Not seekable"); }
sub reset { faint(SP_SEEKERR, "Not seekable"); }
sub seek { faint(SP_SEEKERR, "Not seekable"); }
sub read_binary { faint(SP_MODEERR, "Not readable"); }
sub _write_code { faint(SP_MODEERR, "Not writable"); }
sub _write_text_code { faint(SP_MODEERR, "Not writable"); }

sub describe {
    @_ == 1 or croak "Usage: IO->describe";
    # subclasses will override this if required
    my ($object) = @_;
    my $type = $object->{type};
    my $mode = $object->{mode};
    my $data = $object->{data};
    return "$type($mode, $data)";
}

# method implementing filehandle text READ OUT operations

sub read_text {
    @_ == 2 or croak "Usage: IO->read_text(DATA)";
    my ($fh, $string) = @_;
    faint(SP_MODEERR, "Not set up for text reading")
	if ! exists $fh->{read_convert};
    $string = &{$fh->{read_convert}}($string);
    $fh->read_binary($string);
}

sub read_charset {
    @_ == 1 || @_ == 2 or croak "Usage: IO->read_charset [(CHARSET)]";
    my $fh = shift;
    my $oc = $fh->{read_charset};
    if (@_) {
	my $charset = shift;
	$fh->{read_charset} = $charset;
	$fh->{read_convert} = fromascii($charset);
    }
    $oc;
}

# method implementing filehandle WRITE IN operations

sub write_binary {
    @_ == 2 or croak "Usage: IO->write_binary(SIZE)";
    my ($fh, $size) = @_;
confess "size is undef" if ! defined $size;
    if (length($fh->{buffer}) >= $size) {
	return substr($fh->{buffer}, 0, $size, '');
    }
    my $data = '';
    if ($fh->{buffer} ne '') {
	$data = $fh->{buffer};
	$fh->{buffer} = '';
    }
    my $add = $fh->_write_code($size - length($data));
    defined $add ? ($data . $add) : $data;
}

sub write_text {
    @_ == 1 or @_ == 2 or croak "Usage: IO->write_text [(NEWLINE)]";
    my ($fh, $newline) = @_;
    if (defined $newline) {
	if ($newline ne '') {
	    eval { $newline = $fh->{write_unconvert}->($newline) };
	    $newline = "\n" if $@;
	}
    } else {
	$newline = $fh->{text_newline};
    }
    if ($newline eq '') {
	my $line = $fh->{buffer};
	$fh->{buffer} = '';
	while (1) {
	    my $data = $fh->_write_code(1024);
	    last if ! defined $data || $data eq '';
	    $line .= $data;
	}
	return &{$fh->{write_convert}}($line);
    }
    my $nlpos = index $fh->{buffer}, $newline;
    if ($nlpos >= 0) {
	$nlpos += length($newline);
	my $line = substr($fh->{buffer}, 0, $nlpos, '');
	return &{$fh->{write_convert}}($line);
    }
    my $line = $fh->_write_text_code($newline);
    $line = defined $line ? ($fh->{buffer} . $line) : $fh->{buffer};
    $fh->{buffer} = '';
    return &{$fh->{write_convert}}($line);
}

sub write_charset {
    @_ == 1 || @_ == 2 or croak "Usage: IO->write_charset [(CHARSET)]";
    my $fh = shift;
    my $oc = $fh->{write_charset};
    if (@_) {
	my $charset = shift;
	$fh->{write_charset} = $charset;
	$fh->{write_convert} = toascii($charset);
	$fh->{write_unconvert} = fromascii($charset);
	eval { $fh->{text_newline} = $fh->{write_unconvert}->("\n") };
	$fh->{text_newline} = "\n" if $@;
    }
    $oc;
}

# method used while exporting filehandle

sub mode {
    @_ == 1 or croak "Usage: IO->mode";
    my ($fh) = @_;
    $fh->{mode};
}

sub export {
    @_ == 2 or croak "Usage: IO->export(SERVER)";
    my ($fh, $server) = @_;
    $fh->{exported} and return $fh->{exported};
    my $port = $server->tcp_listen(\&_open, \&_line, \&_close, $fh);
    $fh->{exported} = $port;
    $port;
}

sub _open {
    my ($id, $sockhost, $peerhost, $close, $fh) = @_;
    $fh->{importers}{$id} = [0, 0, 0, ''];
    return "202 $sockhost ($VERSION)";
}

sub _line {
    my ($server, $id, $close, $line, $fh) = @_;
    exists $fh->{importers}{$id}
	or return "580 Internal error in server";
    my $filepos = $fh->{importers}{$id};
    if ($line =~ /^\s*TELL/i) {
	my $filepos = eval { $fh->tell; };
	$@ || ! defined $filepos and return "581 Not seekable";
	return "280 $filepos is the current file position";
    }
    if ($line =~ /^\s*SEEK\s+(-?\d+)\s+(SET|CUR|END)/i) {
	exists $fh->{seek_code} or return "581 Not seekable";
	if ($2 eq 'SET') {
	    $1 < 0 and return "582 Invalid file position";
	    $filepos = $1;
	} elsif ($2 eq 'CUR') {
	    $filepos += $1;
	    $filepos < 0 and return "582 Invalid file position";
	} else {
	    my $delta = $1;
	    my $curpos;
	    $@ = '';
	    eval {
		my $oldpos = $fh->tell;
		$fh->seek(0, SEEK_END);
		$curpos = $fh->tell;
		$oldpos = $fh->seek($oldpos, SEEK_SET);
	    };
	    $@ and return "583 Cannot use SEEK_END on this filehandle";
	    $filepos = $curpos + $delta;
	    $filepos < 0 and return "582 Invalid file position";
	}
	$fh->{importers}{$id} = $filepos;
	return "281 $filepos is the new file position";
    }
    if ($line =~ /^\s*WRITE\s+(\d+)/i) {
	my $size = $1;
	exists $fh->{seek_code} and $fh->{seek_code}->($filepos, SEEK_SET);
	$@ = '';
	my $data = eval { $fh->write_binary($size) };
	if ($@) {
	    $@ =~ s/\n+/ /g;
	    return "584 $@";
	}
	eval {
	    exists $fh->{tell_code}
		and $fh->{importers}{$id} = &{$fh->{tell_code}}();
	};
	my $len = length $data;
	$server->read_out($id, "282 $len");
	$server->read_binary($id, $data);
	return ();
    }
    if ($line =~ /^\s*WRITE\s+TEXT\s+\/(\S*)\//i) {
	my $newline = $1;
	$newline =~ s/!(\d{3})/chr($1)/ge;
	$@ = '';
	my $data = eval {
	    exists $fh->{seek_code}
		and $fh->{seek_code}->($filepos, SEEK_SET);
	    $fh->write_text($newline);
	};
	if ($@) {
	    $@ =~ s/\n+/ /g;
	    return "584 $@";
	}
	eval {
	    exists $fh->{tell_code}
		and $fh->{importers}{$id} = &{$fh->{tell_code}}();
	};
	my $len = length $data;
	$server->read_out($id, "282 $len");
	$server->read_binary($id, $data);
	return ();
    }
    if ($line =~ /^\s*READ\s+(\d+)/i) {
	my $len = $1;
	my $code = sub {
	    my $data = shift;
	    defined $data && length($data) == $len
		or return "585 Data size mismatch";
	    $@ = '';
	    eval {
		exists $fh->{seek_code}
		    and $fh->{seek_code}->($filepos, SEEK_SET);
		$fh->read_binary($data);
	    };
	    if ($@) {
		$@ =~ s/\n+/ /g;
		return "586 $@";
	    }
	    eval {
		exists $fh->{tell_code}
		    and $fh->{importers}{$id} = &{$fh->{tell_code}}();
	    };
	    return "283 OK";
	};
	$server->alternate_callback($id, $len, $code);
	return "383 OK, send the data";
    }
    if ($line =~ /^\s*THANKS/i) {
	$$close = 1;
	return "284 You are welcome";
    }
    if ($line =~ /^\s*ISTERM/i) {
	my $isit = eval { $fh->is_terminal; };
	$@ || ! defined $isit and return "587 Information not available";
	$isit and return "285 Yes";
	return "286 No";
    }
    return "589 Command not understood";
}

sub _close {
    my ($id, $fh) = @_;
    delete $fh->{importers}{$id};
}

1;