|
996
|
1 package Language::INTERCAL::Rcfile;
|
|
|
2
|
|
|
3 # Configuration files for sick and intercalc
|
|
|
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/Rcfile.pm 1.-94.-2") =~ /\s(\S+)$/;
|
|
|
16
|
|
|
17 use Carp;
|
|
|
18 use File::Spec::Functions;
|
|
|
19 use Language::INTERCAL::Exporter '1.-94.-2';
|
|
|
20 use Language::INTERCAL::GenericIO '1.-94.-2';
|
|
|
21
|
|
|
22 my %rcdefs = (
|
|
|
23 'WRITE' => [ \&_rc_array, [], 'Character sets used for guessing' ],
|
|
|
24 'UNDERSTAND' => [ \&_rc_understand, [], 'Suffix to parser mapping' ],
|
|
|
25 'UNDERSTAND ANYWHERE' => [ \&_rc_anywhere, [], undef ],
|
|
|
26 'SPEAK' => [ \&_rc_array, [], 'Default user interfaces' ],
|
|
|
27 'PRODUCE' => [ \&_rc_scalar, '', 'Default compiler back end' ],
|
|
|
28 );
|
|
|
29
|
|
|
30 my %programs = (
|
|
|
31 INTERNET => 'INTERNET defaults',
|
|
|
32 INTERCALC => "Calculator's defaults",
|
|
|
33 );
|
|
|
34
|
|
|
35 sub new {
|
|
|
36 @_ == 1 or croak "Usage: new Language::INTERCAL::Rcfile";
|
|
|
37 my ($class) = @_;
|
|
|
38 my %data = ();
|
|
|
39 for my $k (keys %rcdefs) {
|
|
|
40 $data{$k} = ref $rcdefs{$k}[1] ? [] : '';
|
|
|
41 }
|
|
|
42 my @include =
|
|
|
43 grep { -d $_ }
|
|
|
44 map { catdir($_, qw(Language INTERCAL Include)) }
|
|
|
45 @INC;
|
|
|
46 # TODO - make the following portable (is there such a thing?)
|
|
|
47 my @home = ();
|
|
|
48 if ($ENV{HOME}) {
|
|
|
49 @home = (homedir => $ENV{HOME});
|
|
|
50 } else {
|
|
|
51 my $name = getlogin;
|
|
|
52 if (! $name || ! getpwnam($name)) {
|
|
|
53 $name = getpwuid($<);
|
|
|
54 }
|
|
|
55 if ($name && getpwnam($name)) {
|
|
|
56 @home = (homedir => (getpwnam($name))[7]);
|
|
|
57 }
|
|
|
58 }
|
|
|
59 bless {
|
|
|
60 options => {
|
|
|
61 rcfile => [],
|
|
|
62 include => \@include,
|
|
|
63 nouserrc => 0,
|
|
|
64 },
|
|
|
65 userinc => 0,
|
|
|
66 rccmd => [],
|
|
|
67 data => \%data,
|
|
|
68 prog => {},
|
|
|
69 @home,
|
|
|
70 }, $class;
|
|
|
71 }
|
|
|
72
|
|
|
73 sub setoption {
|
|
|
74 @_ == 3 or croak "Usage: RCFILE->setoption(NAME, VALUE)";
|
|
|
75 my ($rc, $name, $value) = @_;
|
|
|
76 exists $rc->{options}{$name}
|
|
|
77 or die "Unknown option $name\n";
|
|
|
78 if (ref $rc->{options}{$name}) {
|
|
|
79 if ($name eq 'include') {
|
|
|
80 my $userinc = $rc->{userinc}++;
|
|
|
81 splice(@{$rc->{options}{$name}}, $userinc, 0, $value);
|
|
|
82 } else {
|
|
|
83 push @{$rc->{options}{$name}}, $value;
|
|
|
84 }
|
|
|
85 } else {
|
|
|
86 $rc->{options}{$name} = $value;
|
|
|
87 }
|
|
|
88 $rc;
|
|
|
89 }
|
|
|
90
|
|
|
91 sub getoption {
|
|
|
92 @_ == 2 or croak "Usage: RCFILE->getoption(NAME)";
|
|
|
93 my ($rc, $name) = @_;
|
|
|
94 exists $rc->{options}{$name}
|
|
|
95 or die "Unknown option $name\n";
|
|
|
96 $rc->{options}{$name};
|
|
|
97 }
|
|
|
98
|
|
|
99 sub getitem {
|
|
|
100 @_ == 2 or croak "Usage: RCFILE->getitem(NAME)";
|
|
|
101 my ($rc, $name) = @_;
|
|
|
102 exists $rc->{data}{$name}
|
|
|
103 or die "Unknown item $name\n";
|
|
|
104 ref $rc->{data}{$name} or return $rc->{data}{$name};
|
|
|
105 @{$rc->{data}{$name}};
|
|
|
106 }
|
|
|
107
|
|
|
108 sub putitem {
|
|
|
109 @_ == 3 or croak "Usage: RCFILE->putitem(NAME, VALUE)";
|
|
|
110 my ($rc, $name, $value) = @_;
|
|
|
111 exists $rc->{data}{$name}
|
|
|
112 or die "Unknown item $name\n";
|
|
|
113 if (ref $rc->{data}{$name}) {
|
|
|
114 ref $value && UNIVERSAL::isa($value, 'ARRAY')
|
|
|
115 or die "Value for $name should be an array\n";
|
|
|
116 } else {
|
|
|
117 ref $value
|
|
|
118 and die "Value for $name should be a scalar\n";
|
|
|
119 }
|
|
|
120 $rc->{data}{$name} = $value;
|
|
|
121 $rc;
|
|
|
122 }
|
|
|
123
|
|
|
124 sub program_options {
|
|
|
125 @_ == 2 or croak "Usage: RCFILE->program_options(PROGRAM)";
|
|
|
126 my ($rc, $program) = @_;
|
|
|
127 $program = uc($program);
|
|
|
128 exists $rc->{prog}{$program} or return ();
|
|
|
129 %{$rc->{prog}{$program}};
|
|
|
130 }
|
|
|
131
|
|
|
132 sub program_setoptions {
|
|
|
133 @_ == 3 or croak "Usage: RCFILE->program_setoptions(PROGRAM, OPTIONS)";
|
|
|
134 my ($rc, $program, $options) = @_;
|
|
|
135 ref $options && UNIVERSAL::isa($options, 'HASH')
|
|
|
136 or die "Options should be a HASH reference\n";
|
|
|
137 $program = uc($program);
|
|
|
138 $rc->{prog}{$program} = $options;
|
|
|
139 $rc;
|
|
|
140 }
|
|
|
141
|
|
|
142 sub _rc_array {
|
|
|
143 my ($rc, $mode, $ln, $file) = @_;
|
|
|
144 die "Missing value for $mode\n" if $ln eq '';
|
|
|
145 push @{$rc->{data}{$mode}}, $ln;
|
|
|
146 }
|
|
|
147
|
|
|
148 sub _rc_scalar {
|
|
|
149 my ($rc, $mode, $ln, $file) = @_;
|
|
|
150 die "Missing value for $mode\n" if $ln eq '';
|
|
|
151 $rc->{data}{$mode} = $ln;
|
|
|
152 }
|
|
|
153
|
|
|
154 sub _rc_understand {
|
|
|
155 my ($rc, $mode, $ln, $file) = @_;
|
|
|
156 my $suffix;
|
|
|
157 if ($ln =~ s/^(['"])(.*?)\1\s*//) {
|
|
|
158 $suffix = $2;
|
|
|
159 } elsif ($ln =~ s/^(\S+)\s*//) {
|
|
|
160 $suffix = $1;
|
|
|
161 } else {
|
|
|
162 die "$file\: Invalid $mode\: missing SUFFIX\n";
|
|
|
163 }
|
|
|
164 if ($ln =~ s/^ANYWHERE\s*//i) {
|
|
|
165 $mode .= ' ANYWHERE';
|
|
|
166 $ln = $suffix . ' ' . $ln;
|
|
|
167 return &{$rcdefs{$mode}[0]}($rc, $mode, $ln, $file);
|
|
|
168 }
|
|
|
169 $ln =~ s/^AS\s*//i or die "$file\: Invalid $mode\: missing AS\n";
|
|
|
170 my $name;
|
|
|
171 if ($ln =~ s/^(['"])(.*?)\1\s*//) {
|
|
|
172 $name = $2;
|
|
|
173 } elsif ($ln =~ s/^(\w+)\s*//) {
|
|
|
174 $name = $1;
|
|
|
175 } else {
|
|
|
176 die "$file\: Invalid $mode\: missing NAME\n";
|
|
|
177 }
|
|
|
178 my %map = ( '' => [] );
|
|
|
179 while ($ln ne '') {
|
|
|
180 if ($ln =~ s/^WITH\s*//i) {
|
|
|
181 while (1) {
|
|
|
182 my $maybe = '';
|
|
|
183 $maybe = $1 if $ln =~ s/^(\?)//;
|
|
|
184 my $preload;
|
|
|
185 if ($ln =~ s/^(['"])(.*?)\1\s*//) {
|
|
|
186 $preload = $2;
|
|
|
187 } elsif ($ln =~ s/^(\w+)\s*//) {
|
|
|
188 $preload = $1;
|
|
|
189 } else {
|
|
|
190 die "$file\: Invalid $mode\: missing PRELOAD\n";
|
|
|
191 }
|
|
|
192 push @{$map{''}}, $maybe . $preload;
|
|
|
193 $ln =~ s/^\+\s*// or last;
|
|
|
194 }
|
|
|
195 next;
|
|
|
196 }
|
|
|
197 if ($ln =~ s/^DISCARDING\s*//) {
|
|
|
198 my $option;
|
|
|
199 if ($ln =~ s/^(['"])(.*?)\1\s*//) {
|
|
|
200 $option = $2;
|
|
|
201 } elsif ($ln =~ s/^(\S+)\s*//) {
|
|
|
202 $option = $1;
|
|
|
203 } else {
|
|
|
204 die "$file\: Invalid $mode\: missing DISCARDING\n";
|
|
|
205 }
|
|
|
206 $map{$option} = [[], ''];
|
|
|
207 next;
|
|
|
208 }
|
|
|
209 die "$file\: Invalid $mode\: $ln\n";
|
|
|
210 }
|
|
|
211 if ($suffix =~ s/^\.\.([^\.]+)\.//) {
|
|
|
212 # special item used for program configuration - this avoids changing
|
|
|
213 # the syntax of .sickrc again
|
|
|
214 $rc->{prog}{uc $1}{$suffix} = [$name, \%map];
|
|
|
215 } else {
|
|
|
216 push @{$rc->{data}{$mode}}, [$suffix, $name, \%map];
|
|
|
217 }
|
|
|
218 }
|
|
|
219
|
|
|
220 sub _rc_anywhere {
|
|
|
221 my ($rc, $mode, $ln, $file) = @_;
|
|
|
222 my $suffix;
|
|
|
223 if ($ln =~ s/^(['"])(.*?)\1\s*//) {
|
|
|
224 $suffix = $2;
|
|
|
225 } elsif ($ln =~ s/^(\S+)\s*//) {
|
|
|
226 $suffix = $1;
|
|
|
227 } else {
|
|
|
228 die "$file\: Invalid $mode\: missing SUFFIX\n";
|
|
|
229 }
|
|
|
230 $ln =~ s/^AS\s*//i or die "$file\: Invalid $mode\: missing AS\n";
|
|
|
231 my $name;
|
|
|
232 if ($ln =~ s/^(['"])(.*?)\1\s*//) {
|
|
|
233 $name = $2;
|
|
|
234 } elsif ($ln =~ s/^(\w+)\s*//) {
|
|
|
235 $name = $1;
|
|
|
236 } else {
|
|
|
237 die "$file\: Invalid $mode\: missing NAME\n";
|
|
|
238 }
|
|
|
239 $ln =~ s/^WITH\s*//i or die "$file\: Invalid $mode\: missing WITH\n";
|
|
|
240 my @preload = ();
|
|
|
241 while (1) {
|
|
|
242 my $maybe = '';
|
|
|
243 $maybe = $1 if $ln =~ s/^(\?)//;
|
|
|
244 my $preload;
|
|
|
245 if ($ln =~ s/^(['"])(.*?)\1\s*//) {
|
|
|
246 $preload = $2;
|
|
|
247 } elsif ($ln =~ s/^(\S+)\s*//) {
|
|
|
248 $preload = $1;
|
|
|
249 } else {
|
|
|
250 die "$file\: Invalid $mode\: missing PRELOAD\n";
|
|
|
251 }
|
|
|
252 push @preload, $maybe . $preload;
|
|
|
253 $ln =~ s/^\+\s*// or last;
|
|
|
254 }
|
|
|
255 die "$file\: Invalid $mode\: extra data at end ($ln)\n"
|
|
|
256 if $ln ne '';
|
|
|
257 push @{$rc->{data}{$mode}}, [$suffix, \@preload, $name];
|
|
|
258 }
|
|
|
259
|
|
|
260 sub load {
|
|
|
261 @_ == 1 or croak "Usage: RCFILE->load";
|
|
|
262 my ($rc) = @_;
|
|
|
263 unless (@{$rc->{options}{rcfile}}) {
|
|
|
264 my @home = exists $rc->{homedir} ? ($rc->{homedir}) : ();
|
|
|
265 my $u = $rc->{options}{nouserrc};
|
|
|
266 $rc->{options}{rcfile} = [
|
|
|
267 map {canonpath($_)}
|
|
|
268 grep { -f $_ }
|
|
|
269 map { catfile($_, "system.sickrc"),
|
|
|
270 ($u ? () : catfile($_, ".sickrc")),
|
|
|
271 }
|
|
|
272 (@{$rc->{options}{include}}, @home, '.')
|
|
|
273 ];
|
|
|
274 $rc->{options}{rcfile} = [$rc->{options}{rcfile}[0]]
|
|
|
275 if $u && @{$rc->{options}{rcfile}} > 1;
|
|
|
276 }
|
|
|
277 for my $rcfile (@{$rc->{options}{rcfile}}) {
|
|
|
278 my $fh = Language::INTERCAL::GenericIO->new('FILE', 'w', $rcfile)
|
|
|
279 or die "$rcfile: $!\n";
|
|
|
280 my $mode = undef;
|
|
|
281 my $text = '';
|
|
|
282 my $mln = '';
|
|
|
283 my $no = 0;
|
|
|
284 while ('' ne (my $ln = $fh->write_text())) {
|
|
|
285 chomp $ln;
|
|
|
286 $ln =~ s/^\s*//;
|
|
|
287 $no++;
|
|
|
288 next if $ln eq '';
|
|
|
289 my $rn = "$rcfile\:$no";
|
|
|
290 if ($ln =~ s/^(?:DO|PLEASE)\s*NOTE\s*//i) {
|
|
|
291 &{$rcdefs{$mode}[0]}($rc, $mode, $text, $mln)
|
|
|
292 if defined $mode && $mode ne '';
|
|
|
293 $mode = '';
|
|
|
294 } elsif ($ln =~ s/^I\s*DO\s*N[O']T\s*(\S+)//i) {
|
|
|
295 &{$rcdefs{$mode}[0]}($rc, $mode, $text, $mln)
|
|
|
296 if defined $mode && $mode ne '';
|
|
|
297 $mode = uc($1);
|
|
|
298 die "No such action \"$1\": $rn\n"
|
|
|
299 unless exists $rcdefs{$mode};
|
|
|
300 die "Invalid declaration \"$_\": $rn\n"
|
|
|
301 unless ref $rc->{data}{$mode};
|
|
|
302 $rc->{data}{$mode} = [];
|
|
|
303 $mode = undef;
|
|
|
304 } elsif ($ln =~ s/^I\s*CAN\s*(\S+)\s*//i) {
|
|
|
305 &{$rcdefs{$mode}[0]}($rc, $mode, $text, $mln)
|
|
|
306 if defined $mode && $mode ne '';
|
|
|
307 $mode = uc($1);
|
|
|
308 exists $rcdefs{$mode}
|
|
|
309 or die "No such action \"$1\": $rn\n";
|
|
|
310 $text = $ln;
|
|
|
311 $mln = $rn;
|
|
|
312 } elsif (defined $mode) {
|
|
|
313 $text .= ' ' . $ln;
|
|
|
314 } else {
|
|
|
315 die "Syntax error: $rn\n";
|
|
|
316 }
|
|
|
317 }
|
|
|
318 &{$rcdefs{$mode}[0]}($rc, $mode, $text, $mln)
|
|
|
319 if defined $mode && $mode ne '';
|
|
|
320 }
|
|
|
321 $rc;
|
|
|
322 }
|
|
|
323
|
|
|
324 sub save {
|
|
|
325 @_ == 1 || @_ == 2 or croak "Usage: RCFILE->save [(TO)]";
|
|
|
326 my ($rc, $to) = @_;
|
|
|
327 if (! defined $to) {
|
|
|
328 $to = catfile($rc->{homedir}, ".sickrc"),
|
|
|
329 }
|
|
|
330 my $tmp = $to . '.tmp';
|
|
|
331 open(RC, '>', $tmp) or die "$tmp: $!\n";
|
|
|
332 print RC "PLEASE NOTE: This file was automatically generated while saving settings\n\n"
|
|
|
333 or die "$tmp: $!\n";
|
|
|
334 for my $data (sort keys %{$rc->{data}}) {
|
|
|
335 print RC "PLEASE NOTE: $rcdefs{$data}[2]\n" or die "$tmp: $!\n"
|
|
|
336 if defined $rcdefs{$data}[2];
|
|
|
337 if (ref $rc->{data}{$data}) {
|
|
|
338 print RC "I DON'T $data\n" or die "$tmp: $!\n"
|
|
|
339 if defined $rcdefs{$data}[2];
|
|
|
340 for my $value (@{$rc->{data}{$data}}) {
|
|
|
341 if ($data eq 'UNDERSTAND') {
|
|
|
342 my ($suffix, $name, $map) = @$value;
|
|
|
343 $value = "$suffix\n\tAS \"$name\"";
|
|
|
344 my @w = map {
|
|
|
345 if (/\s/) {
|
|
|
346 if (/"/) {
|
|
|
347 "'$_'";
|
|
|
348 } else {
|
|
|
349 "\"$_\"";
|
|
|
350 }
|
|
|
351 } else {
|
|
|
352 $_;
|
|
|
353 }
|
|
|
354 } @{$map->{''}};
|
|
|
355 $value .= "\n\tWITH " . join(' + ', @w);
|
|
|
356 $value .= "\n\tDISCARDING " . join(' + ', sort grep { /./ } keys %$map)
|
|
|
357 if keys %$map > 1;
|
|
|
358 } elsif ($data eq 'UNDERSTAND ANYWHERE') {
|
|
|
359 my ($suffix, $preload, $name) = @$value;
|
|
|
360 $value = "$suffix\n\tAS \"$name\"";
|
|
|
361 if (@$preload) {
|
|
|
362 my @p = map {
|
|
|
363 if (/\s/) {
|
|
|
364 if (/"/) {
|
|
|
365 "'$_'";
|
|
|
366 } else {
|
|
|
367 "\"$_\"";
|
|
|
368 }
|
|
|
369 } else {
|
|
|
370 $_;
|
|
|
371 }
|
|
|
372 } @$preload;
|
|
|
373 $value .= "\n\tWITH " . join(' ', @p);
|
|
|
374 }
|
|
|
375 } elsif ($data =~ /\s/) {
|
|
|
376 if ($data =~ /"/) {
|
|
|
377 $data = "'$data'";
|
|
|
378 } else {
|
|
|
379 $data = "\"$data\"";
|
|
|
380 }
|
|
|
381 }
|
|
|
382 print RC "I CAN $data $value\n" or die "$tmp: $!\n";
|
|
|
383 }
|
|
|
384 } else {
|
|
|
385 print RC "I CAN $data $rc->{data}{$data}\n" or die "$tmp: $!\n";
|
|
|
386 }
|
|
|
387 print RC "\n" or die "$tmp: $!\n";
|
|
|
388 }
|
|
|
389 for my $data (sort keys %{$rc->{prog}}) {
|
|
|
390 my $def = $programs{uc $data} || "Defaults for \L$data";
|
|
|
391 print RC "PLEASE NOTE: $def\n" or die "$tmp: $!\n";
|
|
|
392 for my $key (sort keys %{$rc->{prog}{$data}}) {
|
|
|
393 my ($value, $map) = @{$rc->{prog}{$data}{$key}};
|
|
|
394 my $withr = $map->{''};
|
|
|
395 my $with = $withr && @$withr ? join(' ', ' WITH', map { "\"$_\"" } @$withr) : '';
|
|
|
396 print RC "I CAN UNDERSTAND \"$data.$key\" AS \"$value\"$with\n" or die "$tmp: $!\n";
|
|
|
397 }
|
|
|
398 print RC "\n" or die "$tmp: $!\n";
|
|
|
399 }
|
|
|
400 close RC or die "$tmp: $!\n";
|
|
|
401 my $old = $to . '~';
|
|
|
402 unlink($old);
|
|
|
403 rename($to, $old);
|
|
|
404 rename($tmp, $to) or die "rename($tmp, $to): $!\n";
|
|
|
405 $rc;
|
|
|
406 }
|
|
|
407
|
|
|
408 sub run {
|
|
|
409 @_ == 2 or croak "Usage: RCFILE->run(UI)";
|
|
|
410 my ($rc, $ui) = @_;
|
|
|
411 for my $cmdline (@{$rc->{rccmd}}) {
|
|
|
412 $ui->do($cmdline);
|
|
|
413 }
|
|
|
414 $rc;
|
|
|
415 }
|
|
|
416
|
|
|
417 1;
|
