← Back to branch summary

~ubuntu-branches/ubuntu/trusty/clc-intercal/trusty-proposed

« back to all changes in this revision

Viewing changes to INTERCAL/Sick.pm

  • Committer: Bazaar Package Importer
  • Author(s): Mark Brown
  • Date: 2006-10-08 13:30:54 UTC
  • mfrom: (1.1.1 upstream) (3.1.1 dapper)
  • Revision ID: james.westby@ubuntu.com-20061008133054-fto70u71yoyltr3m
Tags: 1:1.0~2pre1.-94.-4.1-1
* New upstream release.
* Change to dh_installman.

Show diffs side-by-side

added added

removed removed

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