|
996
|
1 package Language::INTERCAL::GenericIO;
|
|
|
2
|
|
|
3 # Write/read data
|
|
|
4
|
|
|
5 # This file is part of CLC-INTERCAL
|
|
|
6
|
|
|
7 # Copyright (c) 2006-2008 Claudio Calvelli, all rights reserved.
|
|
|
8
|
|
|
9 # CLC-INTERCAL is copyrighted software. However, permission to use, modify,
|
|
|
10 # and distribute it is granted provided that the conditions set out in the
|
|
|
11 # licence agreement are met. See files README and COPYING in the distribution.
|
|
|
12
|
|
|
13 use strict;
|
|
|
14 use vars qw($VERSION $PERVERSION);
|
|
|
15 ($VERSION) = ($PERVERSION = "CLC-INTERCAL/Base INTERCAL/GenericIO.pm 1.-94.-2") =~ /\s(\S+)$/;
|
|
|
16
|
|
|
17 use Carp;
|
|
|
18 use IO::File;
|
|
|
19 use Language::INTERCAL::Exporter '1.-94.-2';
|
|
|
20 use Language::INTERCAL::Charset '1.-94.-2', qw(toascii fromascii);
|
|
|
21 use Language::INTERCAL::Splats '1.-94.-2', qw(:SP);
|
|
|
22 use vars qw(@EXPORT @EXPORT_OK @EXPORT_TAGS
|
|
|
23 $stdread $stdwrite $stdsplat $devnull);
|
|
|
24 @EXPORT = ();
|
|
|
25 @EXPORT_OK = qw($stdread $stdwrite $stdsplat $devnull);
|
|
|
26 @EXPORT_TAGS = (files => [qw($stdread $stdwrite $stdsplat $devnull)]);
|
|
|
27
|
|
|
28 $stdread = new Language::INTERCAL::GenericIO('FILE', 'r', '-');
|
|
|
29 $stdwrite = new Language::INTERCAL::GenericIO('FILE', 'w', '-');
|
|
|
30 $stdsplat = new Language::INTERCAL::GenericIO('FILE', 'r', '-2');
|
|
|
31 $devnull = new Language::INTERCAL::GenericIO('TEE', 'r', []);
|
|
|
32
|
|
|
33 sub new {
|
|
|
34 @_ >= 3
|
|
|
35 or croak "Usage: new Language::INTERCAL::GenericIO(TYPE, MODE, DATA)";
|
|
|
36 my ($class, $type, $mode, @data) = @_;
|
|
|
37 if ($mode =~ /^\d+$/) {
|
|
|
38 $mode = chr($mode & 0xff) . ($mode & 0x100 ? '+' : '');
|
|
|
39 }
|
|
|
40 $mode =~ /^[rwau]\+?$/ or faint(SP_IOMODE, $mode);
|
|
|
41 $type = uc($type);
|
|
|
42 my $module = "Language::INTERCAL::GenericIO::$type";
|
|
|
43 eval "use $module";
|
|
|
44 die $@ if $@;
|
|
|
45 my $object = bless {
|
|
|
46 type => $type,
|
|
|
47 mode => $mode,
|
|
|
48 data => \@data,
|
|
|
49 read_convert => sub { shift },
|
|
|
50 read_charset => 'ASCII',
|
|
|
51 write_convert => sub { shift },
|
|
|
52 write_unconvert => sub { shift },
|
|
|
53 write_charset => 'ASCII',
|
|
|
54 text_newline => "\n",
|
|
|
55 exported => 0,
|
|
|
56 buffer => '',
|
|
|
57 }, $module;
|
|
|
58 $object->_new($mode, @data);
|
|
|
59 $object;
|
|
|
60 }
|
|
|
61
|
|
|
62 # methods which subclasses must override
|
|
|
63 sub tell { faint(SP_SEEKERR, "Not seekable"); }
|
|
|
64 sub reset { faint(SP_SEEKERR, "Not seekable"); }
|
|
|
65 sub seek { faint(SP_SEEKERR, "Not seekable"); }
|
|
|
66 sub read_binary { faint(SP_MODEERR, "Not readable"); }
|
|
|
67 sub _write_code { faint(SP_MODEERR, "Not writable"); }
|
|
|
68 sub _write_text_code { faint(SP_MODEERR, "Not writable"); }
|
|
|
69
|
|
|
70 sub describe {
|
|
|
71 @_ == 1 or croak "Usage: IO->describe";
|
|
|
72 # subclasses will override this if required
|
|
|
73 my ($object) = @_;
|
|
|
74 my $type = $object->{type};
|
|
|
75 my $mode = $object->{mode};
|
|
|
76 my $data = $object->{data};
|
|
|
77 return "$type($mode, $data)";
|
|
|
78 }
|
|
|
79
|
|
|
80 # method implementing filehandle text READ OUT operations
|
|
|
81
|
|
|
82 sub read_text {
|
|
|
83 @_ == 2 or croak "Usage: IO->read_text(DATA)";
|
|
|
84 my ($fh, $string) = @_;
|
|
|
85 faint(SP_MODEERR, "Not set up for text reading")
|
|
|
86 if ! exists $fh->{read_convert};
|
|
|
87 $string = &{$fh->{read_convert}}($string);
|
|
|
88 $fh->read_binary($string);
|
|
|
89 }
|
|
|
90
|
|
|
91 sub read_charset {
|
|
|
92 @_ == 1 || @_ == 2 or croak "Usage: IO->read_charset [(CHARSET)]";
|
|
|
93 my $fh = shift;
|
|
|
94 my $oc = $fh->{read_charset};
|
|
|
95 if (@_) {
|
|
|
96 my $charset = shift;
|
|
|
97 $fh->{read_charset} = $charset;
|
|
|
98 $fh->{read_convert} = fromascii($charset);
|
|
|
99 }
|
|
|
100 $oc;
|
|
|
101 }
|
|
|
102
|
|
|
103 # method implementing filehandle WRITE IN operations
|
|
|
104
|
|
|
105 sub write_binary {
|
|
|
106 @_ == 2 or croak "Usage: IO->write_binary(SIZE)";
|
|
|
107 my ($fh, $size) = @_;
|
|
|
108 confess "size is undef" if ! defined $size;
|
|
|
109 if (length($fh->{buffer}) >= $size) {
|
|
|
110 return substr($fh->{buffer}, 0, $size, '');
|
|
|
111 }
|
|
|
112 my $data = '';
|
|
|
113 if ($fh->{buffer} ne '') {
|
|
|
114 $data = $fh->{buffer};
|
|
|
115 $fh->{buffer} = '';
|
|
|
116 }
|
|
|
117 my $add = $fh->_write_code($size - length($data));
|
|
|
118 defined $add ? ($data . $add) : $data;
|
|
|
119 }
|
|
|
120
|
|
|
121 sub write_text {
|
|
|
122 @_ == 1 or @_ == 2 or croak "Usage: IO->write_text [(NEWLINE)]";
|
|
|
123 my ($fh, $newline) = @_;
|
|
|
124 if (defined $newline) {
|
|
|
125 if ($newline ne '') {
|
|
|
126 eval { $newline = $fh->{write_unconvert}->($newline) };
|
|
|
127 $newline = "\n" if $@;
|
|
|
128 }
|
|
|
129 } else {
|
|
|
130 $newline = $fh->{text_newline};
|
|
|
131 }
|
|
|
132 if ($newline eq '') {
|
|
|
133 my $line = $fh->{buffer};
|
|
|
134 $fh->{buffer} = '';
|
|
|
135 while (1) {
|
|
|
136 my $data = $fh->_write_code(1024);
|
|
|
137 last if ! defined $data || $data eq '';
|
|
|
138 $line .= $data;
|
|
|
139 }
|
|
|
140 return &{$fh->{write_convert}}($line);
|
|
|
141 }
|
|
|
142 my $nlpos = index $fh->{buffer}, $newline;
|
|
|
143 if ($nlpos >= 0) {
|
|
|
144 $nlpos += length($newline);
|
|
|
145 my $line = substr($fh->{buffer}, 0, $nlpos, '');
|
|
|
146 return &{$fh->{write_convert}}($line);
|
|
|
147 }
|
|
|
148 my $line = $fh->_write_text_code($newline);
|
|
|
149 $line = defined $line ? ($fh->{buffer} . $line) : $fh->{buffer};
|
|
|
150 $fh->{buffer} = '';
|
|
|
151 return &{$fh->{write_convert}}($line);
|
|
|
152 }
|
|
|
153
|
|
|
154 sub write_charset {
|
|
|
155 @_ == 1 || @_ == 2 or croak "Usage: IO->write_charset [(CHARSET)]";
|
|
|
156 my $fh = shift;
|
|
|
157 my $oc = $fh->{write_charset};
|
|
|
158 if (@_) {
|
|
|
159 my $charset = shift;
|
|
|
160 $fh->{write_charset} = $charset;
|
|
|
161 $fh->{write_convert} = toascii($charset);
|
|
|
162 $fh->{write_unconvert} = fromascii($charset);
|
|
|
163 eval { $fh->{text_newline} = $fh->{write_unconvert}->("\n") };
|
|
|
164 $fh->{text_newline} = "\n" if $@;
|
|
|
165 }
|
|
|
166 $oc;
|
|
|
167 }
|
|
|
168
|
|
|
169 # method used while exporting filehandle
|
|
|
170
|
|
|
171 sub mode {
|
|
|
172 @_ == 1 or croak "Usage: IO->mode";
|
|
|
173 my ($fh) = @_;
|
|
|
174 $fh->{mode};
|
|
|
175 }
|
|
|
176
|
|
|
177 sub export {
|
|
|
178 @_ == 2 or croak "Usage: IO->export(SERVER)";
|
|
|
179 my ($fh, $server) = @_;
|
|
|
180 $fh->{exported} and return $fh->{exported};
|
|
|
181 my $port = $server->tcp_listen(\&_open, \&_line, \&_close, $fh);
|
|
|
182 $fh->{exported} = $port;
|
|
|
183 $port;
|
|
|
184 }
|
|
|
185
|
|
|
186 sub _open {
|
|
|
187 my ($id, $sockhost, $peerhost, $close, $fh) = @_;
|
|
|
188 $fh->{importers}{$id} = [0, 0, 0, ''];
|
|
|
189 return "202 $sockhost ($VERSION)";
|
|
|
190 }
|
|
|
191
|
|
|
192 sub _line {
|
|
|
193 my ($server, $id, $close, $line, $fh) = @_;
|
|
|
194 exists $fh->{importers}{$id}
|
|
|
195 or return "580 Internal error in server";
|
|
|
196 my $filepos = $fh->{importers}{$id};
|
|
|
197 if ($line =~ /^\s*TELL/i) {
|
|
|
198 my $filepos = eval { $fh->tell; };
|
|
|
199 $@ || ! defined $filepos and return "581 Not seekable";
|
|
|
200 return "280 $filepos is the current file position";
|
|
|
201 }
|
|
|
202 if ($line =~ /^\s*SEEK\s+(-?\d+)\s+(SET|CUR|END)/i) {
|
|
|
203 exists $fh->{seek_code} or return "581 Not seekable";
|
|
|
204 if ($2 eq 'SET') {
|
|
|
205 $1 < 0 and return "582 Invalid file position";
|
|
|
206 $filepos = $1;
|
|
|
207 } elsif ($2 eq 'CUR') {
|
|
|
208 $filepos += $1;
|
|
|
209 $filepos < 0 and return "582 Invalid file position";
|
|
|
210 } else {
|
|
|
211 my $delta = $1;
|
|
|
212 my $curpos;
|
|
|
213 $@ = '';
|
|
|
214 eval {
|
|
|
215 my $oldpos = $fh->tell;
|
|
|
216 $fh->seek(0, SEEK_END);
|
|
|
217 $curpos = $fh->tell;
|
|
|
218 $oldpos = $fh->seek($oldpos, SEEK_SET);
|
|
|
219 };
|
|
|
220 $@ and return "583 Cannot use SEEK_END on this filehandle";
|
|
|
221 $filepos = $curpos + $delta;
|
|
|
222 $filepos < 0 and return "582 Invalid file position";
|
|
|
223 }
|
|
|
224 $fh->{importers}{$id} = $filepos;
|
|
|
225 return "281 $filepos is the new file position";
|
|
|
226 }
|
|
|
227 if ($line =~ /^\s*WRITE\s+(\d+)/i) {
|
|
|
228 my $size = $1;
|
|
|
229 exists $fh->{seek_code} and $fh->{seek_code}->($filepos, SEEK_SET);
|
|
|
230 $@ = '';
|
|
|
231 my $data = eval { $fh->write_binary($size) };
|
|
|
232 if ($@) {
|
|
|
233 $@ =~ s/\n+/ /g;
|
|
|
234 return "584 $@";
|
|
|
235 }
|
|
|
236 eval {
|
|
|
237 exists $fh->{tell_code}
|
|
|
238 and $fh->{importers}{$id} = &{$fh->{tell_code}}();
|
|
|
239 };
|
|
|
240 my $len = length $data;
|
|
|
241 $server->read_out($id, "282 $len");
|
|
|
242 $server->read_binary($id, $data);
|
|
|
243 return ();
|
|
|
244 }
|
|
|
245 if ($line =~ /^\s*WRITE\s+TEXT\s+\/(\S*)\//i) {
|
|
|
246 my $newline = $1;
|
|
|
247 $newline =~ s/!(\d{3})/chr($1)/ge;
|
|
|
248 $@ = '';
|
|
|
249 my $data = eval {
|
|
|
250 exists $fh->{seek_code}
|
|
|
251 and $fh->{seek_code}->($filepos, SEEK_SET);
|
|
|
252 $fh->write_text($newline);
|
|
|
253 };
|
|
|
254 if ($@) {
|
|
|
255 $@ =~ s/\n+/ /g;
|
|
|
256 return "584 $@";
|
|
|
257 }
|
|
|
258 eval {
|
|
|
259 exists $fh->{tell_code}
|
|
|
260 and $fh->{importers}{$id} = &{$fh->{tell_code}}();
|
|
|
261 };
|
|
|
262 my $len = length $data;
|
|
|
263 $server->read_out($id, "282 $len");
|
|
|
264 $server->read_binary($id, $data);
|
|
|
265 return ();
|
|
|
266 }
|
|
|
267 if ($line =~ /^\s*READ\s+(\d+)/i) {
|
|
|
268 my $len = $1;
|
|
|
269 my $code = sub {
|
|
|
270 my $data = shift;
|
|
|
271 defined $data && length($data) == $len
|
|
|
272 or return "585 Data size mismatch";
|
|
|
273 $@ = '';
|
|
|
274 eval {
|
|
|
275 exists $fh->{seek_code}
|
|
|
276 and $fh->{seek_code}->($filepos, SEEK_SET);
|
|
|
277 $fh->read_binary($data);
|
|
|
278 };
|
|
|
279 if ($@) {
|
|
|
280 $@ =~ s/\n+/ /g;
|
|
|
281 return "586 $@";
|
|
|
282 }
|
|
|
283 eval {
|
|
|
284 exists $fh->{tell_code}
|
|
|
285 and $fh->{importers}{$id} = &{$fh->{tell_code}}();
|
|
|
286 };
|
|
|
287 return "283 OK";
|
|
|
288 };
|
|
|
289 $server->alternate_callback($id, $len, $code);
|
|
|
290 return "383 OK, send the data";
|
|
|
291 }
|
|
|
292 if ($line =~ /^\s*THANKS/i) {
|
|
|
293 $$close = 1;
|
|
|
294 return "284 You are welcome";
|
|
|
295 }
|
|
|
296 if ($line =~ /^\s*ISTERM/i) {
|
|
|
297 my $isit = eval { $fh->is_terminal; };
|
|
|
298 $@ || ! defined $isit and return "587 Information not available";
|
|
|
299 $isit and return "285 Yes";
|
|
|
300 return "286 No";
|
|
|
301 }
|
|
|
302 return "589 Command not understood";
|
|
|
303 }
|
|
|
304
|
|
|
305 sub _close {
|
|
|
306 my ($id, $fh) = @_;
|
|
|
307 delete $fh->{importers}{$id};
|
|
|
308 }
|
|
|
309
|
|
|
310 1;
|
