|
996
|
1 package Language::INTERCAL::GenericIO::REMOTE;
|
|
|
2
|
|
|
3 # Write/read data from/to remote file
|
|
|
4
|
|
|
5 # This file is part of CLC-INTERCAL
|
|
|
6
|
|
|
7 # Copyright (c) 2007-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/REMOTE.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::Splats '1.-94.-2', qw(:SP);
|
|
|
21 use Language::INTERCAL::GenericIO '1.-94.-2';
|
|
|
22 use vars qw(@ISA);
|
|
|
23 @ISA = qw(Language::INTERCAL::GenericIO);
|
|
|
24
|
|
|
25 sub _new {
|
|
|
26 @_ == 4 or croak
|
|
|
27 "Usage: new Language::INTERCAL::GenericIO::REMOTE(MODE, ADDR, SERVER)";
|
|
|
28 my ($object, $mode, $data, $server) = @_;
|
|
|
29 $data =~ s/:(\w+)$//
|
|
|
30 or croak "DATA must be host:port when TYPE is REMOTE";
|
|
|
31 my $port = $1;
|
|
|
32 my $host = $data;
|
|
|
33 my $id = $server->tcp_socket($data, $port);
|
|
|
34 my $line = $server->write_in($id, 1);
|
|
|
35 defined $line or faint(SP_INTERNET, $host, 'Lost connection');
|
|
|
36 $line =~ /^2/ or faint(SP_INTERNET, $host, $line);
|
|
|
37 $object->{filedata} = {
|
|
|
38 id => $id,
|
|
|
39 server => $server,
|
|
|
40 host => $host,
|
|
|
41 port => $port,
|
|
|
42 };
|
|
|
43 }
|
|
|
44
|
|
|
45 sub is_terminal {
|
|
|
46 @_ == 1 or croak "Usage: IO->is_terminal";
|
|
|
47 my ($object) = @_;
|
|
|
48 my $server = $object->{filedata}{server};
|
|
|
49 my $id = $object->{filedata}{id};
|
|
|
50 $server->read_out($id, "ISTERM");
|
|
|
51 my $line = $server->write_in($id, 1);
|
|
|
52 my $host = $object->{filedata}{host};
|
|
|
53 defined $line or faint(SP_INTERNET, $host, 'Lost connection');
|
|
|
54 $line =~ /^2/ or faint(SP_INTERNET, $host, $line);
|
|
|
55 $line =~ /^285/ and return 1;
|
|
|
56 0;
|
|
|
57 }
|
|
|
58
|
|
|
59 sub read_binary {
|
|
|
60 @_ == 2 or croak "Usage: IO->read_binary(DATA)";
|
|
|
61 my ($object, $data) = @_;
|
|
|
62 my $len = length $data;
|
|
|
63 my $server = $object->{filedata}{server};
|
|
|
64 my $id = $object->{filedata}{id};
|
|
|
65 my $host = $object->{filedata}{host};
|
|
|
66 $server->read_out($id, "READ $len");
|
|
|
67 my $line = $server->write_in($id, 1);
|
|
|
68 defined $line or faint(SP_INTERNET, $host, 'Lost connection');
|
|
|
69 $line =~ /^3/ or faint(SP_INTERNET, $host, $line);
|
|
|
70 $server->read_binary($id, $data);
|
|
|
71 $line = $server->write_in($id, 1);
|
|
|
72 defined $line or faint(SP_INTERNET, $host, 'Lost connection');
|
|
|
73 $line =~ /^2/ or faint(SP_INTERNET, $host, $line);
|
|
|
74 $object;
|
|
|
75 }
|
|
|
76
|
|
|
77 sub _write_code {
|
|
|
78 my ($object, $size) = @_;
|
|
|
79 my $server = $object->{filedata}{server};
|
|
|
80 my $id = $object->{filedata}{id};
|
|
|
81 my $host = $object->{filedata}{host};
|
|
|
82 $server->read_out($id, "WRITE $size");
|
|
|
83 my $line = $server->write_in($id, 1);
|
|
|
84 defined $line or faint(SP_INTERNET, $host, 'Lost connection');
|
|
|
85 $line =~ /^2\d+\s+(\d+)/ or faint(SP_INTERNET, $host, $line);
|
|
|
86 my $len = $1;
|
|
|
87 my $data = $server->write_binary($id, $len);
|
|
|
88 defined $data or faint(SP_INTERNET, $host, 'Lost connection');
|
|
|
89 length($data) == $len or faint(SP_INTERNET, $host, "Invalid data");
|
|
|
90 $data;
|
|
|
91 }
|
|
|
92
|
|
|
93 sub _write_text_code {
|
|
|
94 my ($object, $newline) = @_;
|
|
|
95 my $server = $object->{filedata}{server};
|
|
|
96 my $id = $object->{filedata}{id};
|
|
|
97 my $host = $object->{filedata}{host};
|
|
|
98 $newline =~ s/(\W)/sprintf("!%03d", ord($1))/ge;
|
|
|
99 $server->read_out($id, "WRITE TEXT /$newline/");
|
|
|
100 my $line = $server->write_in($id, 1);
|
|
|
101 defined $line or faint(SP_INTERNET, $host, 'Lost connection');
|
|
|
102 $line =~ /^2\d+\s+(\d+)/ or faint(SP_INTERNET, $host, $line);
|
|
|
103 my $len = $1;
|
|
|
104 my $data = $server->write_binary($id, $len);
|
|
|
105 defined $data or faint(SP_INTERNET, $host, 'Lost connection');
|
|
|
106 length($data) == $len or faint(SP_INTERNET, $host, "Invalid data");
|
|
|
107 $data;
|
|
|
108 }
|
|
|
109
|
|
|
110 sub tell {
|
|
|
111 @_ == 1 or croak "Usage: IO->tell";
|
|
|
112 my ($object) = @_;
|
|
|
113 my $server = $object->{filedata}{server};
|
|
|
114 my $id = $object->{filedata}{id};
|
|
|
115 my $host = $object->{filedata}{host};
|
|
|
116 $server->read_out($id, 'TELL');
|
|
|
117 my $line = $server->write_in($id, 1);
|
|
|
118 defined $line or faint(SP_INTERNET, $host, 'Lost connection');
|
|
|
119 $line =~ /^2\d+\s+(\d+)/ or faint(SP_INTERNET, $host, $line);
|
|
|
120 return $1;
|
|
|
121 }
|
|
|
122
|
|
|
123 sub reset {
|
|
|
124 @_ == 1 or croak "Usage: IO->reset";
|
|
|
125 my ($object) = @_;
|
|
|
126 $object->seek(0, SEEK_SET);
|
|
|
127 }
|
|
|
128
|
|
|
129 sub seek {
|
|
|
130 @_ == 2 || @_ == 3
|
|
|
131 or croak "Usage: IO->seek(POS [, RELATIVE_TO])";
|
|
|
132 my ($object, $pos, $rel) = @_;
|
|
|
133 if ($rel == SEEK_SET) {
|
|
|
134 $rel = 'SET';
|
|
|
135 } elsif ($rel == SEEK_CUR) {
|
|
|
136 $rel = 'CUR';
|
|
|
137 } elsif ($rel == SEEK_END) {
|
|
|
138 $rel = 'END';
|
|
|
139 } else {
|
|
|
140 faint(SP_SEEKERR, "Invalid file position $rel");
|
|
|
141 }
|
|
|
142 my $server = $object->{filedata}{server};
|
|
|
143 my $id = $object->{filedata}{id};
|
|
|
144 my $host = $object->{filedata}{host};
|
|
|
145 $server->read_out($id, "SEEK $pos $rel");
|
|
|
146 my $line = $server->write_in($id, 1);
|
|
|
147 defined $line or faint(SP_INTERNET, $host, 'Lost connection');
|
|
|
148 $line =~ /^2/ or faint(SP_INTERNET, $host, $line);
|
|
|
149 $object->{buffer} = '';
|
|
|
150 $object;
|
|
|
151 }
|
|
|
152
|
|
|
153 sub DESTROY {
|
|
|
154 my ($object) = @_;
|
|
|
155 my $server = $object->{filedata}{server};
|
|
|
156 my $id = $object->{filedata}{id};
|
|
|
157 eval { $server->tcp_socket_close($id); }
|
|
|
158 }
|
|
|
159
|
|
|
160 sub describe {
|
|
|
161 @_ == 1 or croak "Usage: IO->describe";
|
|
|
162 my ($object) = @_;
|
|
|
163 my $host = $object->{filedata}{host};
|
|
|
164 my $port = $object->{filedata}{port};
|
|
|
165 return "REMOTE($host:$port)";
|
|
|
166 }
|
|
|
167
|
|
|
168 1;
|
