Mercurial > repo
view interps/clc-intercal/CLC-INTERCAL-Base-1.-94.-2/INTERCAL/GenericIO.pm @ 3553:a2c0fbb7c2b1
<Roujo> revert
author | HackBot |
---|---|
date | Thu, 29 Aug 2013 20:30:48 +0000 |
parents | 859f9b4339e6 |
children |
line wrap: on
line source
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;