Mercurial > repo

comparison interps/clc-intercal/CLC-INTERCAL-Base-1.-94.-2/INTERCAL/Sick.pm @ 996:859f9b4339e6

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
<Gregor> tar xf egobot.tar.xz
author HackBot
date Sun, 09 Dec 2012 19:30:08 +0000
parents
children
comparison
equal deleted inserted replaced
995:6883f5911eb7 996:859f9b4339e6
1 package Language::INTERCAL::Sick;
2
3 # Compiler/user interface/whatnot for CLC-INTERCAL
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/Sick.pm 1.-94.-2") =~ /\s(\S+)$/;
16
17 use Carp;
18 use File::Basename;
19 use File::Spec::Functions;
20 use Language::INTERCAL::Exporter '1.-94.-2';
21 use Language::INTERCAL::Charset '1.-94.-2', qw(charset_name toascii charset);
22 use Language::INTERCAL::GenericIO '1.-94.-2';
23 use Language::INTERCAL::Backend '1.-94.-2', qw(backend generate_code);
24 use Language::INTERCAL::Interpreter '1.-94.-2';
25
26 sub new {
27 @_ == 2 or croak "Usage: new Language::INTERCAL::Sick(RC)";
28 my ($class, $rc) = @_;
29 bless {
30 object_option => {
31 backend => '',
32 bug => 1,
33 charset => '',
34 name => '%o',
35 optimise => 0,
36 output => '%p.%s',
37 preload => [],
38 suffix => '',
39 trace => undef,
40 trace_fh => undef,
41 ubug => 0.01,
42 verbose => 0,
43 },
44 shared_option => {
45 default_backend => 'Object',
46 default_charset => [],
47 default_extra => [],
48 default_suffix => [],
49 preload_callback => undef,
50 },
51 sources => [],
52 filepath => {},
53 shared_filepath => {},
54 int_cache => {},
55 loaded => 0,
56 rc => $rc,
57 theft_server => 0,
58 server => 0,
59 }, $class;
60 }
61
62 sub reset {
63 @_ == 1 or croak "Usage: SICK->reset";
64 my ($sick) = @_;
65 $sick->{loaded} = 0;
66 $sick->{sources} = [];
67 $sick;
68 }
69
70 my %checkoption = (
71 backend => \&_load_backend,
72 bug => \&_check_bug,
73 charset => \&_load_charset,
74 default_backend => \&_load_backend,
75 default_charset => \&_load_charset,
76 default_extra => \&_check_extra,
77 default_suffix => \&_check_suffix,
78 optimise => \&_check_bool,
79 preload => \&_check_object,
80 preload_callback => \&_check_callback,
81 trace => \&_check_bool,
82 trace_fh => \&_check_filehandle,
83 ubug => \&_check_bug,
84 verbose => \&_check_filehandle,
85 );
86
87 my %object_type = (
88 IACC => 'COMPILER',
89 COMPILER => 'COMPILER',
90 ASSEMBLER => 'COMPILER',
91 RUNCOMPILER => 'COMPILER',
92 BASE => 'ONEONLY',
93 POSTPRE => 'ONEONLY',
94 EXTENSION => 'REPEAT',
95 OPTION => 'REPEAT',
96 OPTIMISER => 'REPEAT',
97 );
98
99 sub option {
100 @_ == 2 or @_ == 3 or croak "Usage: SICK->option(NAME [, VALUE])";
101 @_ == 2 ? shift->getoption(@_) : shift->setoption(@_);
102 }
103
104 sub getoption {
105 @_ == 2 or croak "Usage: SICK->getoption(NAME)";
106 my ($sick, $name) = @_;
107 my $value = exists $sick->{object_option}{$name}
108 ? $sick->{object_option}{$name}
109 : exists $sick->{shared_option}{$name}
110 ? $sick->{shared_option}{$name}
111 : die "Unknown option $name\n";
112 return $value unless ref $value;
113 return $value if UNIVERSAL::isa($value, 'Language::INTERCAL::GenericIO');
114 return @$value if 'ARRAY' eq ref $value;
115 return map { ($_ => [@{$value->{$_}}]) } keys %$value
116 if 'HASH' eq ref $value;
117 return (); # should never get here
118 }
119
120 sub setoption {
121 @_ == 3 or croak "Usage: SICK->setoption(NAME, VALUE)";
122 my ($sick, $name, $value) = @_;
123 my $hash = exists $sick->{object_option}{$name}
124 ? $sick->{object_option}
125 : exists $sick->{shared_option}{$name}
126 ? $sick->{shared_option}
127 : die "Unknown option $name\n";
128 if (exists $checkoption{$name}) {
129 $value = $checkoption{$name}->($name, $sick, $value);
130 }
131 if (! ref $hash->{$name}) {
132 $hash->{$name} = $value;
133 } elsif (UNIVERSAL::isa($value, 'Language::INTERCAL::GenericIO')) {
134 $hash->{$name} = $value;
135 } elsif ('ARRAY' eq ref $hash->{$name}) {
136 push @{$hash->{$name}}, $value;
137 } elsif ('HASH' eq ref $hash->{$name}) {
138 my ($key, $as, @add) = @$value;
139 if (exists $hash->{$name}{$key}) {
140 $hash->{$name}{$key}[0] = $as;
141 } else {
142 $hash->{$name}{$key} = [$as];
143 }
144 push @{$hash->{$name}{$key}}, @add;
145 } else {
146 # not supposed to get here
147 die "Cannot set option $name\n";
148 }
149 $sick;
150 }
151
152 sub clearoption {
153 @_ == 2 or croak "Usage: SICK->clearoption(NAME)";
154 my ($sick, $name) = @_;
155 my $hash = exists $sick->{object_option}{$name}
156 ? $sick->{object_option}
157 : exists $sick->{shared_option}{$name}
158 ? $sick->{shared_option}
159 : die "Unknown option $name\n";
160 if (ref $hash->{$name}) {
161 if (UNIVERSAL::isa($hash->{$name}, 'Language::INTERCAL::GenericIO')) {
162 $hash->{$name} = 0;
163 } elsif ('ARRAY' eq ref $hash->{$name}) {
164 $hash->{$name} = [];
165 } elsif ('HASH' eq ref $hash->{$name}) {
166 $hash->{$name} = {};
167 } else {
168 die "Cannot clear option $name\n";
169 }
170 } else {
171 die "Cannot clear option $name\n";
172 }
173 $sick;
174 }
175
176 sub alloptions {
177 @_ == 1 or @_ == 2 or croak "Usage: SICK->alloptions [(shared)]";
178 my ($sick, $shared) = @_;
179 my %vals = ();
180 my @hash = ();
181 push @hash, 'object_option' if ! defined $shared || ! $shared;
182 push @hash, 'shared_option' if ! defined $shared || ! $shared;
183 for my $hash (@hash) {
184 while (my ($name, $value) = each %{$sick->{$hash}}) {
185 if (! ref $value) {
186 # nothing, but we don't want to be caught in next cases
187 } elsif (UNIVERSAL::isa($value, 'Language::INTERCAL::GenericIO')) {
188 # nothing, but we don't want to be caught in next cases
189 } elsif ('ARRAY' eq ref $value) {
190 # a shallow copy will do -- we know values are strings
191 $value = [ @$value ];
192 } elsif ('HASH' eq ref $value) {
193 # two level deep copy: the values are arrays of strings
194 my %v = ();
195 while (my ($key, $val) = each %$value) {
196 $v{$key} = [ @$val ];
197 }
198 $value = \%v;
199 } elsif (ref $value) {
200 # WTF?
201 $value = undef;
202 }
203 $vals{$name} = $value;
204 }
205 }
206 %vals;
207 }
208
209 sub source {
210 @_ == 2 or croak "Usage: SICK->source(FILENAME)";
211 my ($sick, $file) = @_;
212 $file = _check_file($sick, $file);
213 push @{$sick->{sources}}, {
214 'source' => $file,
215 'option' => { $sick->alloptions(0) }, # don't copy shared options
216 'filepath' => $sick->{filepath},
217 };
218 $sick->{loaded} = 0;
219 $sick;
220 }
221
222 sub load_objects {
223 @_ == 1 or croak "Usage: SICK->load_objects()";
224 my ($sick) = @_;
225 return $sick if $sick->{loaded};
226 for (my $i = 0; $i < @{$sick->{sources}}; $i++) {
227 my $object = $sick->{sources}[$i];
228 next if exists $object->{object};
229 my $o = $object->{option};
230 my ($obj, $fn, $base, $is_src) = _load_source($sick, $object, $o);
231 $object->{is_src} = $is_src;
232 $object->{base} = $base;
233 $object->{object} = $obj;
234 $object->{filename} = $fn;
235 }
236 $sick->{loaded} = 1;
237 $sick;
238 }
239
240 sub save_objects {
241 @_ == 2 or croak "Usage: SICK->save_objects(AND_KEEP?)";
242 my ($sick, $keep) = @_;
243 $sick->load_objects();
244 for my $object (@{$sick->{sources}}) {
245 my $o = $object->{option};
246 my $backend = $o->{backend};
247 next unless $object->{is_src} || $backend ne 'Object';
248 my $out = $o->{output};
249 next if $out eq '';
250 $backend = $sick->{shared_option}{default_backend}
251 if $backend eq '';
252 my $v = $o->{verbose} ? sub {
253 my ($name) = @_;
254 $o->{verbose}->read_text($name eq '' ? 'Running...'
255 : "Saving $name... ");
256 } : '';
257 my $orig = $object->{source};
258 $orig =~ s/\.[^.]*$//;
259 my %op = (
260 verbose => $v,
261 );
262 generate_code($object->{object}, $backend, $o->{name},
263 $object->{base}, $out, $orig, \%op);
264 $o->{verbose}->read_text("OK\n") if $o->{verbose};
265 undef $object unless $keep;
266 }
267 $sick;
268 }
269
270 sub theft_server {
271 @_ == 2 or croak "Usage: SICK->theft_server(SERVER)";
272 my ($sick, $server) = @_;
273 $sick->{theft_server} = $server;
274 $sick;
275 }
276
277 sub server {
278 @_ == 2 or croak "Usage: SICK->server(SERVER)";
279 my ($sick, $server) = @_;
280 $sick->{server} = $server;
281 $sick;
282 }
283
284 sub get_object {
285 @_ == 2 or croak "Usage: SICK->get_object(NAME)";
286 my ($sick, $name) = @_;
287 for my $o (@{$sick->{sources}}) {
288 next if $o->{source} ne $name;
289 return $o->{object};
290 }
291 undef;
292 }
293
294
295 sub all_objects {
296 @_ == 2 || @_ == 3
297 or croak "Usage: SICK->all_objects(CALLBACK [, JUST_FLAGS])";
298 my ($sick, $callback, $just_flags) = @_;
299 for my $search (@{$sick->{rc}->getoption('include')}) {
300 opendir(SEARCH, $search) or next;
301 while (defined (my $ent = readdir SEARCH)) {
302 $ent =~ /^(.*)\.io$/ or next;
303 my $name = $1;
304 my $file = catfile($search, $ent);
305 -f $file or next;
306 eval {
307 my $fh = Language::INTERCAL::GenericIO->new('FILE', 'w', $file);
308 my $ob = Language::INTERCAL::Object->write($fh, $just_flags);
309 my $type = undef;
310 $ob->has_flag('TYPE')
311 and $type = $ob->flag_value('TYPE');
312 $callback->($name, $file, $type, $ob);
313 };
314 }
315 closedir SEARCH;
316 }
317 $sick;
318 }
319
320 # private methods follow
321
322 sub _check_bool {
323 my ($name, $sick, $value) = @_;
324 return $value if $value =~ /^\d+$/;
325 return 1 if $value =~ /^t(?:rue)?$/i;
326 return 1 if $value =~ /^y(?:es)?$/i;
327 return 0 if $value =~ /^f(?:alse)?$/i;
328 return 0 if $value =~ /^n(?:o)?$/i;
329 die "Invalid value for $name\: '$value'\n";
330 }
331
332 sub _check_filehandle {
333 my ($name, $sick, $value) = @_;
334 return $value if ref $value &&
335 UNIVERSAL::isa($value, 'Language::INTERCAL::GenericIO');
336 return undef if $value =~ /^\d+$/ && $value == 0;
337 return undef if $value =~ /^n(?:one)?$/i;
338 die "Invalid filehandle value '$value'\n";
339 }
340
341 sub _check_path {
342 my ($name, $sick, $value) = @_;
343 return $value if -d $value;
344 die "Invalid path '$value'\n";
345 }
346
347 sub _check_bug {
348 my ($name, $sick, $value) = @_;
349 $value =~ /^(?:\d+(?:\.\d*)?|\.\d+)$/
350 or die "Value '$value' is not a positive number\n";
351 $value <= 100
352 or die "Value '$value' is too large for a probability\n";
353 $value;
354 }
355
356 sub _check_extra {
357 my ($name, $sick, $value) = @_;
358 ref $value && ref $value eq 'ARRAY'
359 or die "Invalid value for $name (must be a array ref)\n";
360 @$value == 3
361 or die "Invalid value for $name (requires three elements)\n";
362 my ($extra, $preload, $as) = @$value;
363 ref $preload && ref $preload eq 'ARRAY'
364 or die "Invalid value for $name (preloads must be array ref)\n";
365 [$extra, $preload, $as];
366 }
367
368 sub _check_suffix {
369 my ($name, $sick, $value) = @_;
370 ref $value && ref $value eq 'ARRAY'
371 or die "Invalid value for $name (must be a array ref)\n";
372 @$value == 3
373 or die "Invalid value for $name (requires three elements)\n";
374 my ($suffix, $as, $map) = @$value;
375 ref $map && ref $map eq 'HASH'
376 or die "Invalid value for $name (third element must be hash ref)\n";
377 exists $map->{''} && ref $map->{''} && ref $map->{''} eq 'ARRAY'
378 or die "Invalid value for $name (preloads must be array ref)\n";
379 # suffix map have alternatives expressed as something like
380 # ./2:3:4:5:6:7/i => .2i .3i ... .7i
381 # ./l:n:g:t://i => .li .ni .gi .ti .lni .nli ...
382 # note that we have no nesting of alternatives; use different rules
383 my @resplit = ();
384 my $regex = '';
385 while ($suffix =~ s#^(.*?)/##) {
386 $regex .= quotemeta($1);
387 $suffix =~ s#^(.*?)/##
388 or die "Invalid value for $name\: unclosed / in suffix\n";
389 my @extra = split(/:/, $1);
390 for my $extra (@extra) {
391 exists $map->{$extra} or next;
392 ref $map->{$extra} && ref $map->{$extra} eq 'ARRAY'
393 or die "Invalid value for $name " .
394 "(preloads for $extra must be array ref)\n";
395 }
396 my $extra = join('|', map { quotemeta } @extra);
397 my $star = $suffix =~ s#^:## ? '*' : '';
398 $regex .= '((?:' . $extra . ')' . $star . ')';
399 push @resplit, qr/^($extra)/;
400 }
401 $regex .= quotemeta($suffix) . '$';
402 $regex = qr/$regex/i;
403 return [$regex, $as, \@resplit, $map];
404 }
405
406 sub _find_file {
407 my ($sick, $value, $ftype, $cache, $path) = @_;
408 return $cache->{$value} if exists $cache->{$value};
409 # try opening file from current directory
410 if (-f $value) {
411 $cache->{$value} = $value;
412 return $value;
413 }
414 if (! file_name_is_absolute($value)) {
415 my ($file, $dir) = fileparse($value);
416 $path = $sick->{rc}->getoption('include') if ! defined $path;
417 for my $search (@$path) {
418 my $n = catfile($search, $dir, $file);
419 $n = canonpath($n);
420 if (-f $n) {
421 $cache->{$value} = $n;
422 return $n;
423 }
424 }
425 }
426 die "Cannot find $ftype \"$value\"\n";
427 }
428
429 sub _check_file {
430 my ($sick, $value) = @_;
431 _find_file($sick, $value, 'file',
432 $sick->{filecache},
433 $sick->{rc}->getoption('include'));
434 $value;
435 }
436
437 sub _find_object {
438 my ($sick, $value, $cache, $path) = @_;
439 if ($value !~ /\.ior?$/) {
440 # try adding suffix first
441 my $v = eval {
442 _find_file($sick, $value . '.io', 'object', $cache, $path);
443 };
444 unless ($@) {
445 return $v . 'r' if -f $v . 'r';
446 return $v;
447 }
448 }
449 _find_file($sick, $value, 'object', $cache, $path);
450 }
451
452 sub _check_object {
453 my ($name, $sick, $value) = @_;
454 # _find_object($sick, $value,
455 # $sick->{filecache},
456 # $sick->{rc}->getoption('include'));
457 $value;
458 }
459
460 sub _check_callback {
461 my ($name, $sick, $value) = @_;
462 ! $value and return $value; # unset callback
463 ref $value && UNIVERSAL::isa($value, 'CODE')
464 and return [$value];
465 ref $value && UNIVERSAL::isa($value, 'ARRAY')
466 or die "Invalid callback, must be a CODE or ARRAY reference\n";
467 ref $value->[0] && UNIVERSAL::isa($value->[0], 'CODE')
468 or die "Invalid callback, first element must be a CODE reference\n";
469 $value;
470 }
471
472 sub _open_file {
473 my ($sick, $source, $cache, $path) = @_;
474 my $fn = _find_file($sick, $source, 'file', $cache, $path);
475 my $fh = Language::INTERCAL::GenericIO->new('FILE', 'w', $fn);
476 ($fn, $fh);
477 }
478
479 sub _load_backend {
480 my ($name, $sick, $value) = @_;
481 defined backend($value)
482 or die "Invalid backend: $value";
483 $value;
484 }
485
486 sub _load_charset {
487 my ($name, $sick, $value) = @_;
488 defined charset_name($value)
489 or die "Invalid charset: $value\n";
490 $value;
491 }
492
493 sub _load_source {
494 my ($sick, $source, $o) = @_;
495 my ($fn, $fh) = _open_file($sick, $source->{source},
496 $source->{filepath},
497 $sick->{rc}->getoption('include'));
498 $o->{verbose}->read_text("$fn... ") if $o->{verbose};
499 my $base = $fn;
500 my $suffix = '';
501 if ($o->{suffix}) {
502 $suffix = $o->{suffix};
503 $suffix = '.' . $suffix if $suffix !~ /^\./;
504 $base =~ s/(\.[^.]*)$//; # remove and ignore suffix
505 } elsif ($base =~ s/(\.[^.]*)$//) {
506 $suffix = lc($1);
507 }
508 # first see if it is a real object (you never know)
509 my $int = eval {
510 Language::INTERCAL::Interpreter->write($sick->{rc}, $fh);
511 };
512 if (defined $int && ref $int) {
513 $o->{verbose}->read_text("[COMPILER OBJECT]\n") if $o->{verbose};
514 $int->server($sick->{server});
515 $int->theft_server($sick->{theft_server});
516 $int->setreg('TRFH', $o->{trace_fh}) if defined $o->{trace_fh};
517 $int->setreg('TM', $o->{trace}) if defined $o->{trace};
518 return ($int, $fn, $base, 0);
519 }
520 # failed for whatever reason, we'll try loading as a source
521 $fh->reset();
522 my @preload = @{$o->{preload}};
523 @preload = _guess_preloads($sick, $suffix, $o)
524 unless @preload;
525 # try to find a compiler
526 my @options = ();
527 my @compiler = ();
528 my %preloaded = ();
529 for my $p (@preload, 'postpre') {
530 next if $p eq '';
531 _preload($sick, $p, $source->{filepath}, $o, \%preloaded,
532 \@options, \@compiler);
533 }
534 exists $preloaded{COMPILER}
535 or die "Invalid preload list: no compiler\n";
536 # load the compiler and run it if required
537 if ($compiler[1]) {
538 # compiler saved using RunObject
539 $int = $compiler[0];
540 } else {
541 # compiler saved using Object - create a new interpreter and run the
542 # compiler in it
543 $int = Language::INTERCAL::Interpreter->new($sick->{rc});
544 unshift @options, $compiler[0];
545 }
546 $int->server($sick->{server});
547 $int->theft_server($sick->{theft_server});
548 $int->setreg('TRFH', $o->{trace_fh}) if defined $o->{trace_fh};
549 $int->setreg('TM', $o->{trace}) if defined $o->{trace};
550 my $obj = $int->object;
551 if ($o->{bug} > 0) {
552 $obj->setbug(0, $o->{bug});
553 } else {
554 $obj->setbug(1, $o->{ubug});
555 }
556 # execute all the options
557 for my $p (@options) {
558 $int->start(1)->run($p)->stop();
559 }
560 # do we need to guess character set?
561 my $chr = $o->{charset};
562 if ($chr eq '') {
563 $chr = _guess_charset($sick, $source->{source}, $fh);
564 }
565 $fh->write_charset($chr);
566 $fh->reset();
567 # now read file
568 my $line = 1;
569 my $col = 1;
570 my $scount = 0;
571 my $text = $fh->write_text('');
572 $o->{verbose}->read_text("\n source: " . length($text) . " bytes")
573 if $o->{verbose};
574 $obj->source($text);
575 $int->verbose_compile($o->{verbose});
576 $int->compile($text);
577 $o->{verbose}->read_text(" [object: " . _int_size($obj) . " bytes]")
578 if $o->{verbose};
579 $o->{verbose}->read_text("\n") if $o->{verbose};
580 return ($int, $fn, $base, 1);
581 }
582
583 sub _preload {
584 my ($sick, $file, $cache, $o, $preloaded, $options, $compiler) = @_;
585 my $fn = _find_object($sick, $file, $cache,
586 $sick->{rc}->getoption('include'));
587 $o->{verbose}->read_text("\n [$file: $fn") if $o->{verbose};
588 my ($ci, $size);
589 if (exists $sick->{int_cache}{$fn}) {
590 ($ci, $size) = @{$sick->{int_cache}{$fn}};
591 if ($o->{verbose} && ! $size) {
592 $sick->{int_cache}{$fn}[1] = $size = _int_size($ci);
593 }
594 } else {
595 my $fh = Language::INTERCAL::GenericIO->new('FILE', 'w', $fn);
596 $ci = Language::INTERCAL::Interpreter->write($sick->{rc}, $fh);
597 $size = $o->{verbose} ? _int_size($ci) : 0;
598 $sick->{int_cache}{$fn} = [$ci, $size];
599 }
600 $ci->object->has_flag('TYPE')
601 or die "Invalid object - did not provide a type\n";
602 my $ct = $ci->object->flag_value('TYPE');
603 exists $object_type{$ct} or die "Invalid object type: $ct\n";
604 my $ot = $object_type{$ct};
605 if ($ot eq 'COMPILER') {
606 exists $preloaded->{$ct}
607 and die "Invalid preloads list - compiler " .
608 "$preloaded->{$ot} already loaded\n";
609 $preloaded->{$ot} = $file;
610 $compiler->[0] = $ci;
611 $compiler->[1] = $ct eq 'RUNCOMPILER';
612 } elsif ($ot eq 'ONEONLY') {
613 exists $preloaded->{$ct}
614 and die "Invalid preloads list - \L$ct\E " .
615 "$preloaded->{$ct} already loaded\n";
616 $preloaded->{$ct} = $file;
617 push @$options, $ci;
618 } elsif ($ot eq 'REPEAT') {
619 push @$options, $ci;
620 } else {
621 die "Internal error, unmapped type $ot\n";
622 }
623 # if they want to do additional checks, let them
624 if ($sick->{shared_option}{preload_callback}) {
625 my ($code, @args) = @{$sick->{shared_option}{preload_callback}};
626 $code->($sick, $file, $fn, $ct, @args);
627 }
628 $o->{verbose}->read_text(": type \L$ct\E: $size bytes]") if $o->{verbose};
629 }
630
631 sub _guess_extra {
632 my ($sick, $extra) = @_;
633 for my $xd (@{$sick->{shared_option}{default_extra}}) {
634 my ($x, $preload, $as) = @$xd;
635 next if $x ne $extra;
636 return ($preload, $as);
637 }
638 ();
639 }
640
641 sub _guess_preloads {
642 my ($sick, $suffix, $o) = @_;
643 # must guess preloads from suffix
644 for my $sd (@{$sick->{shared_option}{default_suffix}}) {
645 my ($regex, $as, $resplit, $map) = @$sd;
646 next unless ref $resplit;
647 my @extra = $suffix =~ $regex;
648 next unless @extra;
649 if (@$resplit) {
650 my @e = ();
651 for my $r (@$resplit) {
652 my $e = shift @extra;
653 next unless defined $e;
654 while ($e =~ s/$r//) {
655 push @e, $1;
656 }
657 die "Internal error in _guess_preloads\n" if $e ne '';
658 }
659 @extra = @e;
660 } else {
661 @extra = ();
662 }
663 my @preloads = ();
664 my %preloads = ();
665 for my $p (@{$map->{''}}) {
666 my $q = $p;
667 if ($q =~ s/^\?//) {
668 next unless $o->{optimise};
669 }
670 push @preloads, $q;
671 $preloads{$q} = 1;
672 }
673 my @as = ( $as );
674 my %as = ( $as => 1 );
675 for my $extra (@extra) {
676 my ($_p, $a);
677 if (exists $map->{$extra}) {
678 ($_p, $a) = @{$map->{$extra}};
679 } else {
680 ($_p, $a) = _guess_extra($sick, $extra);
681 die "Inconsistent sickrc: $extra?\n" unless defined $_p;
682 }
683 for my $p (@$_p) {
684 my $q = $p;
685 if ($q =~ s/^\?//) {
686 next unless $o->{optimise};
687 }
688 next if exists $preloads{$q};
689 push @preloads, $q;
690 $preloads{$q} = 1;
691 }
692 next if $a eq '' || exists $as{$a};
693 push @as, $a;
694 $as{$a} = 1;
695 }
696 $o->{verbose}->read_text(" [" . join(' + ', @as) . "]")
697 if $o->{verbose};
698 return @preloads;
699 }
700 die "Cannot guess file type\n";
701 }
702
703 sub _guess_charset {
704 my ($sick, $source, $fh) = @_;
705 my %counts = ();
706 for my $name (@{$sick->{shared_option}{default_charset}}) {
707 eval {
708 my $cnv = toascii($name);
709 my $count = 0;
710 while ((my $line = $fh->write_binary(4096)) ne '') {
711 my $cl = &$cnv($line);
712 $count++ while $line =~ /DO|PLEASE/ig;
713 }
714 $counts{$name} = $count;
715 };
716 $fh->reset();
717 }
718 my @counts =
719 sort {$counts{$b} <=> $counts{$a}} grep {$counts{$_}} keys %counts;
720 if (@counts == 0 && $fh->write_binary(1) eq '') {
721 $fh->reset();
722 @counts = qw(ASCII);
723 $counts{ASCII} = 1;
724 }
725 if (! @counts || $counts{$counts[0]} < 1) {
726 my $cr = $sick->{object_option}{verbose} ? "\n" : "";
727 die "${cr}File \"$source\": cannot guess character set\n";
728 }
729 $counts[0];
730 }
731
732 sub _int_size {
733 my ($int) = @_;
734 my $size = 0;
735 my $fh = new Language::INTERCAL::GenericIO 'COUNT', 'r', \$size;
736 $int->read($fh);
737 $size;
738 }
739
740 1