clc-intercal 1:1.0~4pre1.-94.-2-2 / usr / share / perl5 / Language / INTERCAL / Sick.pm

package Language::INTERCAL::Sick;

# Compiler/user interface/whatnot for CLC-INTERCAL

# This file is part of CLC-INTERCAL

# Copyright (c) 2006-2008 Claudio Calvelli, all rights reserved.

# CLC-INTERCAL is copyrighted software. However, permission to use, modify,
# and distribute it is granted provided that the conditions set out in the
# licence agreement are met. See files README and COPYING in the distribution.

use strict;
use vars qw($VERSION $PERVERSION);
($VERSION) = ($PERVERSION = "CLC-INTERCAL/Base INTERCAL/Sick.pm 1.-94.-2") =~ /\s(\S+)$/;

use Carp;
use File::Basename;
use File::Spec::Functions;
use Language::INTERCAL::Exporter '1.-94.-2';
use Language::INTERCAL::Charset '1.-94.-2', qw(charset_name toascii charset);
use Language::INTERCAL::GenericIO '1.-94.-2';
use Language::INTERCAL::Backend '1.-94.-2', qw(backend generate_code);
use Language::INTERCAL::Interpreter '1.-94.-2';

sub new {
    @_ == 2 or croak "Usage: new Language::INTERCAL::Sick(RC)";
    my ($class, $rc) = @_;
    bless {
	object_option => {
	    backend            => '',
	    bug                => 1,
	    charset            => '',
	    name               => '%o',
	    optimise           => 0,
	    output             => '%p.%s',
	    preload            => [],
	    suffix             => '',
	    trace              => undef,
	    trace_fh           => undef,
	    ubug               => 0.01,
	    verbose            => 0,
	},
	shared_option => {
	    default_backend    => 'Object',
	    default_charset    => [],
	    default_extra      => [],
	    default_suffix     => [],
	    preload_callback   => undef,
	},
	sources => [],
	filepath => {},
	shared_filepath => {},
	int_cache => {},
	loaded => 0,
	rc => $rc,
	theft_server => 0,
	server => 0,
    }, $class;
}

sub reset {
    @_ == 1 or croak "Usage: SICK->reset";
    my ($sick) = @_;
    $sick->{loaded} = 0;
    $sick->{sources} = [];
    $sick;
}

my %checkoption = (
    backend          => \&_load_backend,
    bug              => \&_check_bug,
    charset          => \&_load_charset,
    default_backend  => \&_load_backend,
    default_charset  => \&_load_charset,
    default_extra    => \&_check_extra,
    default_suffix   => \&_check_suffix,
    optimise         => \&_check_bool,
    preload          => \&_check_object,
    preload_callback => \&_check_callback,
    trace            => \&_check_bool,
    trace_fh         => \&_check_filehandle,
    ubug             => \&_check_bug,
    verbose          => \&_check_filehandle,
);

my %object_type = (
    IACC        => 'COMPILER',
    COMPILER    => 'COMPILER',
    ASSEMBLER   => 'COMPILER',
    RUNCOMPILER => 'COMPILER',
    BASE        => 'ONEONLY',
    POSTPRE     => 'ONEONLY',
    EXTENSION   => 'REPEAT',
    OPTION      => 'REPEAT',
    OPTIMISER   => 'REPEAT',
);

sub option {
    @_ == 2 or @_ == 3 or croak "Usage: SICK->option(NAME [, VALUE])";
    @_ == 2 ? shift->getoption(@_) : shift->setoption(@_);
}

sub getoption {
    @_ == 2 or croak "Usage: SICK->getoption(NAME)";
    my ($sick, $name) = @_;
    my $value = exists $sick->{object_option}{$name}
	? $sick->{object_option}{$name}
	: exists $sick->{shared_option}{$name}
	    ? $sick->{shared_option}{$name}
	    : die "Unknown option $name\n";
    return $value unless ref $value;
    return $value if UNIVERSAL::isa($value, 'Language::INTERCAL::GenericIO');
    return @$value if 'ARRAY' eq ref $value;
    return map { ($_ => [@{$value->{$_}}]) } keys %$value
	if 'HASH' eq ref $value;
    return (); # should never get here
}

sub setoption {
    @_ == 3 or croak "Usage: SICK->setoption(NAME, VALUE)";
    my ($sick, $name, $value) = @_;
    my $hash = exists $sick->{object_option}{$name}
	? $sick->{object_option}
	: exists $sick->{shared_option}{$name}
	    ? $sick->{shared_option}
	    : die "Unknown option $name\n";
    if (exists $checkoption{$name}) {
	$value = $checkoption{$name}->($name, $sick, $value);
    }
    if (! ref $hash->{$name}) {
	$hash->{$name} = $value;
    } elsif (UNIVERSAL::isa($value, 'Language::INTERCAL::GenericIO')) {
	$hash->{$name} = $value;
    } elsif ('ARRAY' eq ref $hash->{$name}) {
	push @{$hash->{$name}}, $value;
    } elsif ('HASH' eq ref $hash->{$name}) {
	my ($key, $as, @add) = @$value;
	if (exists $hash->{$name}{$key}) {
	    $hash->{$name}{$key}[0] = $as;
	} else {
	    $hash->{$name}{$key} = [$as];
	}
	push @{$hash->{$name}{$key}}, @add;
    } else {
	# not supposed to get here
	die "Cannot set option $name\n";
    }
    $sick;
}

sub clearoption {
    @_ == 2 or croak "Usage: SICK->clearoption(NAME)";
    my ($sick, $name) = @_;
    my $hash = exists $sick->{object_option}{$name}
	? $sick->{object_option}
	: exists $sick->{shared_option}{$name}
	    ? $sick->{shared_option}
	    : die "Unknown option $name\n";
    if (ref $hash->{$name}) {
	if (UNIVERSAL::isa($hash->{$name}, 'Language::INTERCAL::GenericIO')) {
	    $hash->{$name} = 0;
	} elsif ('ARRAY' eq ref $hash->{$name}) {
	    $hash->{$name} = [];
	} elsif ('HASH' eq ref $hash->{$name}) {
	    $hash->{$name} = {};
	} else {
	    die "Cannot clear option $name\n";
	}
    } else {
	die "Cannot clear option $name\n";
    }
    $sick;
}

sub alloptions {
    @_ == 1 or @_ == 2 or croak "Usage: SICK->alloptions [(shared)]";
    my ($sick, $shared) = @_;
    my %vals = ();
    my @hash = ();
    push @hash, 'object_option' if ! defined $shared || ! $shared;
    push @hash, 'shared_option' if ! defined $shared || ! $shared;
    for my $hash (@hash) {
	while (my ($name, $value) = each %{$sick->{$hash}}) {
	    if (! ref $value) {
		# nothing, but we don't want to be caught in next cases
	    } elsif (UNIVERSAL::isa($value, 'Language::INTERCAL::GenericIO')) {
		# nothing, but we don't want to be caught in next cases
	    } elsif ('ARRAY' eq ref $value) {
		# a shallow copy will do -- we know values are strings
		$value = [ @$value ];
	    } elsif ('HASH' eq ref $value) {
		# two level deep copy: the values are arrays of strings
		my %v = ();
		while (my ($key, $val) = each %$value) {
		    $v{$key} = [ @$val ];
		}
		$value = \%v;
	    } elsif (ref $value) {
		# WTF?
		$value = undef;
	    }
	    $vals{$name} = $value;
	}
    }
    %vals;
}

sub source {
    @_ == 2 or croak "Usage: SICK->source(FILENAME)";
    my ($sick, $file) = @_;
    $file = _check_file($sick, $file);
    push @{$sick->{sources}}, {
	'source' => $file,
	'option' => { $sick->alloptions(0) }, # don't copy shared options
	'filepath' => $sick->{filepath},
    };
    $sick->{loaded} = 0;
    $sick;
}

sub load_objects {
    @_ == 1 or croak "Usage: SICK->load_objects()";
    my ($sick) = @_;
    return $sick if $sick->{loaded};
    for (my $i = 0; $i < @{$sick->{sources}}; $i++) {
	my $object = $sick->{sources}[$i];
	next if exists $object->{object};
	my $o = $object->{option};
	my ($obj, $fn, $base, $is_src) = _load_source($sick, $object, $o);
	$object->{is_src} = $is_src;
	$object->{base} = $base;
	$object->{object} = $obj;
	$object->{filename} = $fn;
    }
    $sick->{loaded} = 1;
    $sick;
}

sub save_objects {
    @_ == 2 or croak "Usage: SICK->save_objects(AND_KEEP?)";
    my ($sick, $keep) = @_;
    $sick->load_objects();
    for my $object (@{$sick->{sources}}) {
	my $o = $object->{option};
	my $backend = $o->{backend};
	next unless $object->{is_src} || $backend ne 'Object';
	my $out = $o->{output};
	next if $out eq '';
	$backend = $sick->{shared_option}{default_backend}
	    if $backend eq '';
	my $v = $o->{verbose} ? sub {
	    my ($name) = @_;
	    $o->{verbose}->read_text($name eq '' ? 'Running...'
						 : "Saving $name... ");
	} : '';
	my $orig = $object->{source};
	$orig =~ s/\.[^.]*$//;
	my %op = (
	    verbose => $v,
	);
	generate_code($object->{object}, $backend, $o->{name},
		      $object->{base}, $out, $orig, \%op);
	$o->{verbose}->read_text("OK\n") if $o->{verbose};
	undef $object unless $keep;
    }
    $sick;
}

sub theft_server {
    @_ == 2 or croak "Usage: SICK->theft_server(SERVER)";
    my ($sick, $server) = @_;
    $sick->{theft_server} = $server;
    $sick;
}

sub server {
    @_ == 2 or croak "Usage: SICK->server(SERVER)";
    my ($sick, $server) = @_;
    $sick->{server} = $server;
    $sick;
}

sub get_object {
    @_ == 2 or croak "Usage: SICK->get_object(NAME)";
    my ($sick, $name) = @_;
    for my $o (@{$sick->{sources}}) {
	next if $o->{source} ne $name;
	return $o->{object};
    }
    undef;
}


sub all_objects {
    @_ == 2 || @_ == 3
	or croak "Usage: SICK->all_objects(CALLBACK [, JUST_FLAGS])";
    my ($sick, $callback, $just_flags) = @_;
    for my $search (@{$sick->{rc}->getoption('include')}) {
	opendir(SEARCH, $search) or next;
	while (defined (my $ent = readdir SEARCH)) {
	    $ent =~ /^(.*)\.io$/ or next;
	    my $name = $1;
	    my $file = catfile($search, $ent);
	    -f $file or next;
	    eval {
		my $fh = Language::INTERCAL::GenericIO->new('FILE', 'w', $file);
		my $ob = Language::INTERCAL::Object->write($fh, $just_flags);
		my $type = undef;
		$ob->has_flag('TYPE')
		    and $type = $ob->flag_value('TYPE');
		$callback->($name, $file, $type, $ob);
	    };
	}
	closedir SEARCH;
    }
    $sick;
}

# private methods follow

sub _check_bool {
    my ($name, $sick, $value) = @_;
    return $value if $value =~ /^\d+$/;
    return 1 if $value =~ /^t(?:rue)?$/i;
    return 1 if $value =~ /^y(?:es)?$/i;
    return 0 if $value =~ /^f(?:alse)?$/i;
    return 0 if $value =~ /^n(?:o)?$/i;
    die "Invalid value for $name\: '$value'\n";
}

sub _check_filehandle {
    my ($name, $sick, $value) = @_;
    return $value if ref $value &&
		     UNIVERSAL::isa($value, 'Language::INTERCAL::GenericIO');
    return undef if $value =~ /^\d+$/ && $value == 0;
    return undef if $value =~ /^n(?:one)?$/i;
    die "Invalid filehandle value '$value'\n";
}

sub _check_path {
    my ($name, $sick, $value) = @_;
    return $value if -d $value;
    die "Invalid path '$value'\n";
}

sub _check_bug {
    my ($name, $sick, $value) = @_;
    $value =~ /^(?:\d+(?:\.\d*)?|\.\d+)$/
	or die "Value '$value' is not a positive number\n";
    $value <= 100
	or die "Value '$value' is too large for a probability\n";
    $value;
}

sub _check_extra {
    my ($name, $sick, $value) = @_;
    ref $value && ref $value eq 'ARRAY'
	or die "Invalid value for $name (must be a array ref)\n";
    @$value == 3
	or die "Invalid value for $name (requires three elements)\n";
    my ($extra, $preload, $as) = @$value;
    ref $preload && ref $preload eq 'ARRAY'
	or die "Invalid value for $name (preloads must be array ref)\n";
    [$extra, $preload, $as];
}

sub _check_suffix {
    my ($name, $sick, $value) = @_;
    ref $value && ref $value eq 'ARRAY'
	or die "Invalid value for $name (must be a array ref)\n";
    @$value == 3
	or die "Invalid value for $name (requires three elements)\n";
    my ($suffix, $as, $map) = @$value;
    ref $map && ref $map eq 'HASH'
	or die "Invalid value for $name (third element must be hash ref)\n";
    exists $map->{''} && ref $map->{''} && ref $map->{''} eq 'ARRAY'
	or die "Invalid value for $name (preloads must be array ref)\n";
    # suffix map have alternatives expressed as something like
    # ./2:3:4:5:6:7/i => .2i .3i ... .7i
    # ./l:n:g:t://i => .li .ni .gi .ti .lni .nli ...
    # note that we have no nesting of alternatives; use different rules
    my @resplit = ();
    my $regex = '';
    while ($suffix =~ s#^(.*?)/##) {
	$regex .= quotemeta($1);
	$suffix =~ s#^(.*?)/##
	    or die "Invalid value for $name\: unclosed / in suffix\n";
	my @extra = split(/:/, $1);
	for my $extra (@extra) {
	    exists $map->{$extra} or next;
	    ref $map->{$extra} && ref $map->{$extra} eq 'ARRAY'
		or die "Invalid value for $name " .
		       "(preloads for $extra must be array ref)\n";
	}
	my $extra = join('|', map { quotemeta } @extra);
	my $star = $suffix =~ s#^:## ? '*' : '';
	$regex .= '((?:' . $extra . ')' . $star . ')';
	push @resplit, qr/^($extra)/;
    }
    $regex .= quotemeta($suffix) . '$';
    $regex = qr/$regex/i;
    return [$regex, $as, \@resplit, $map];
}

sub _find_file {
    my ($sick, $value, $ftype, $cache, $path) = @_;
    return $cache->{$value} if exists $cache->{$value};
    # try opening file from current directory
    if (-f $value) {
	$cache->{$value} = $value;
	return $value;
    }
    if (! file_name_is_absolute($value)) {
	my ($file, $dir) = fileparse($value);
	$path = $sick->{rc}->getoption('include') if ! defined $path;
	for my $search (@$path) {
	    my $n = catfile($search, $dir, $file);
	    $n = canonpath($n);
	    if (-f $n) {
		$cache->{$value} = $n;
		return $n;
	    }
	}
    }
    die "Cannot find $ftype \"$value\"\n";
}

sub _check_file {
    my ($sick, $value) = @_;
    _find_file($sick, $value, 'file',
	       $sick->{filecache},
	       $sick->{rc}->getoption('include'));
    $value;
}

sub _find_object {
    my ($sick, $value, $cache, $path) = @_;
    if ($value !~ /\.ior?$/) {
	# try adding suffix first
	my $v = eval {
	    _find_file($sick, $value . '.io', 'object', $cache, $path);
	};
	unless ($@) {
	    return $v . 'r' if -f $v . 'r';
	    return $v;
	}
    }
    _find_file($sick, $value, 'object', $cache, $path);
}

sub _check_object {
    my ($name, $sick, $value) = @_;
#    _find_object($sick, $value,
#		 $sick->{filecache},
#		 $sick->{rc}->getoption('include'));
    $value;
}

sub _check_callback {
    my ($name, $sick, $value) = @_;
    ! $value and return $value; # unset callback
    ref $value && UNIVERSAL::isa($value, 'CODE')
	and return [$value];
    ref $value && UNIVERSAL::isa($value, 'ARRAY')
	or die "Invalid callback, must be a CODE or ARRAY reference\n";
    ref $value->[0] && UNIVERSAL::isa($value->[0], 'CODE')
	or die "Invalid callback, first element must be a CODE reference\n";
    $value;
}

sub _open_file {
    my ($sick, $source, $cache, $path) = @_;
    my $fn = _find_file($sick, $source, 'file', $cache, $path);
    my $fh = Language::INTERCAL::GenericIO->new('FILE', 'w', $fn);
    ($fn, $fh);
}

sub _load_backend {
    my ($name, $sick, $value) = @_;
    defined backend($value)
	or die "Invalid backend: $value";
    $value;
}

sub _load_charset {
    my ($name, $sick, $value) = @_;
    defined charset_name($value)
	or die "Invalid charset: $value\n";
    $value;
}

sub _load_source {
    my ($sick, $source, $o) = @_;
    my ($fn, $fh) = _open_file($sick, $source->{source},
			       $source->{filepath},
			       $sick->{rc}->getoption('include'));
    $o->{verbose}->read_text("$fn... ") if $o->{verbose};
    my $base = $fn;
    my $suffix = '';
    if ($o->{suffix}) {
	$suffix = $o->{suffix};
	$suffix = '.' . $suffix if $suffix !~ /^\./;
	$base =~ s/(\.[^.]*)$//; # remove and ignore suffix
    } elsif ($base =~ s/(\.[^.]*)$//) {
	$suffix = lc($1);
    }
    # first see if it is a real object (you never know)
    my $int = eval {
	Language::INTERCAL::Interpreter->write($sick->{rc}, $fh);
    };
    if (defined $int && ref $int) {
	$o->{verbose}->read_text("[COMPILER OBJECT]\n") if $o->{verbose};
	$int->server($sick->{server});
	$int->theft_server($sick->{theft_server});
	$int->setreg('TRFH', $o->{trace_fh}) if defined $o->{trace_fh};
	$int->setreg('TM', $o->{trace}) if defined $o->{trace};
	return ($int, $fn, $base, 0);
    }
    # failed for whatever reason, we'll try loading as a source
    $fh->reset();
    my @preload = @{$o->{preload}};
    @preload = _guess_preloads($sick, $suffix, $o)
	unless @preload;
    # try to find a compiler
    my @options = ();
    my @compiler = ();
    my %preloaded = ();
    for my $p (@preload, 'postpre') {
	next if $p eq '';
	_preload($sick, $p, $source->{filepath}, $o, \%preloaded,
		 \@options, \@compiler);
    }
    exists $preloaded{COMPILER}
	or die "Invalid preload list: no compiler\n";
    # load the compiler and run it if required
    if ($compiler[1]) {
	# compiler saved using RunObject
	$int = $compiler[0];
    } else {
	# compiler saved using Object - create a new interpreter and run the
	# compiler in it
	$int = Language::INTERCAL::Interpreter->new($sick->{rc});
	unshift @options, $compiler[0];
    }
    $int->server($sick->{server});
    $int->theft_server($sick->{theft_server});
    $int->setreg('TRFH', $o->{trace_fh}) if defined $o->{trace_fh};
    $int->setreg('TM', $o->{trace}) if defined $o->{trace};
    my $obj = $int->object;
    if ($o->{bug} > 0) {
	$obj->setbug(0, $o->{bug});
    } else {
	$obj->setbug(1, $o->{ubug});
    }
    # execute all the options
    for my $p (@options) {
	$int->start(1)->run($p)->stop();
    }
    # do we need to guess character set?
    my $chr = $o->{charset};
    if ($chr eq '') {
	$chr = _guess_charset($sick, $source->{source}, $fh);
    }
    $fh->write_charset($chr);
    $fh->reset();
    # now read file
    my $line = 1;
    my $col = 1;
    my $scount = 0;
    my $text = $fh->write_text('');
    $o->{verbose}->read_text("\n    source: " . length($text) . " bytes")
	if $o->{verbose};
    $obj->source($text);
    $int->verbose_compile($o->{verbose});
    $int->compile($text);
    $o->{verbose}->read_text(" [object: " . _int_size($obj) . " bytes]")
	if $o->{verbose};
    $o->{verbose}->read_text("\n") if $o->{verbose};
    return ($int, $fn, $base, 1);
}

sub _preload {
    my ($sick, $file, $cache, $o, $preloaded, $options, $compiler) = @_;
    my $fn = _find_object($sick, $file, $cache,
			  $sick->{rc}->getoption('include'));
    $o->{verbose}->read_text("\n    [$file: $fn") if $o->{verbose};
    my ($ci, $size);
    if (exists $sick->{int_cache}{$fn}) {
	($ci, $size) = @{$sick->{int_cache}{$fn}};
	if ($o->{verbose} && ! $size) {
	    $sick->{int_cache}{$fn}[1] = $size = _int_size($ci);
	}
    } else {
	my $fh = Language::INTERCAL::GenericIO->new('FILE', 'w', $fn);
	$ci = Language::INTERCAL::Interpreter->write($sick->{rc}, $fh);
	$size = $o->{verbose} ? _int_size($ci) : 0;
	$sick->{int_cache}{$fn} = [$ci, $size];
    }
    $ci->object->has_flag('TYPE')
	or die "Invalid object - did not provide a type\n";
    my $ct = $ci->object->flag_value('TYPE');
    exists $object_type{$ct} or die "Invalid object type: $ct\n";
    my $ot = $object_type{$ct};
    if ($ot eq 'COMPILER') {
	exists $preloaded->{$ct}
	    and die "Invalid preloads list - compiler " .
		    "$preloaded->{$ot} already loaded\n";
	$preloaded->{$ot} = $file;
	$compiler->[0] = $ci;
	$compiler->[1] = $ct eq 'RUNCOMPILER';
    } elsif ($ot eq 'ONEONLY') {
	exists $preloaded->{$ct}
	    and die "Invalid preloads list - \L$ct\E " .
		    "$preloaded->{$ct} already loaded\n";
	$preloaded->{$ct} = $file;
	push @$options, $ci;
    } elsif ($ot eq 'REPEAT') {
	push @$options, $ci;
    } else {
	die "Internal error, unmapped type $ot\n";
    }
    # if they want to do additional checks, let them
    if ($sick->{shared_option}{preload_callback}) {
	my ($code, @args) = @{$sick->{shared_option}{preload_callback}};
	$code->($sick, $file, $fn, $ct, @args);
    }
    $o->{verbose}->read_text(": type \L$ct\E: $size bytes]") if $o->{verbose};
}

sub _guess_extra {
    my ($sick, $extra) = @_;
    for my $xd (@{$sick->{shared_option}{default_extra}}) {
	my ($x, $preload, $as) = @$xd;
	next if $x ne $extra;
	return ($preload, $as);
    }
    ();
}

sub _guess_preloads {
    my ($sick, $suffix, $o) = @_;
    # must guess preloads from suffix
    for my $sd (@{$sick->{shared_option}{default_suffix}}) {
	my ($regex, $as, $resplit, $map) = @$sd;
	next unless ref $resplit;
	my @extra = $suffix =~ $regex;
	next unless @extra;
	if (@$resplit) {
	    my @e = ();
	    for my $r (@$resplit) {
		my $e = shift @extra;
		next unless defined $e;
		while ($e =~ s/$r//) {
		    push @e, $1;
		}
		die "Internal error in _guess_preloads\n" if $e ne '';
	    }
	    @extra = @e;
	} else {
	    @extra = ();
	}
	my @preloads = ();
	my %preloads = ();
	for my $p (@{$map->{''}}) {
	    my $q = $p;
	    if ($q =~ s/^\?//) {
		next unless $o->{optimise};
	    }
	    push @preloads, $q;
	    $preloads{$q} = 1;
	}
	my @as = ( $as );
	my %as = ( $as => 1 );
	for my $extra (@extra) {
	    my ($_p, $a);
	    if (exists $map->{$extra}) {
		($_p, $a) = @{$map->{$extra}};
	    } else {
		($_p, $a) = _guess_extra($sick, $extra);
		die "Inconsistent sickrc: $extra?\n" unless defined $_p;
	    }
	    for my $p (@$_p) {
		my $q = $p;
		if ($q =~ s/^\?//) {
		    next unless $o->{optimise};
		}
		next if exists $preloads{$q};
		push @preloads, $q;
		$preloads{$q} = 1;
	    }
	    next if $a eq '' || exists $as{$a};
	    push @as, $a;
	    $as{$a} = 1;
	}
	$o->{verbose}->read_text(" [" . join(' + ', @as) . "]")
	    if $o->{verbose};
	return @preloads;
    }
    die "Cannot guess file type\n";
}

sub _guess_charset {
    my ($sick, $source, $fh) = @_;
    my %counts = ();
    for my $name (@{$sick->{shared_option}{default_charset}}) {
	eval {
	    my $cnv = toascii($name);
	    my $count = 0;
	    while ((my $line = $fh->write_binary(4096)) ne '') {
		    my $cl = &$cnv($line);
		    $count++ while $line =~ /DO|PLEASE/ig;
	    }
	    $counts{$name} = $count;
	};
	$fh->reset();
    }
    my @counts =
	sort {$counts{$b} <=> $counts{$a}} grep {$counts{$_}} keys %counts;
    if (@counts == 0 && $fh->write_binary(1) eq '') {
	$fh->reset();
	@counts = qw(ASCII);
	$counts{ASCII} = 1;
    }
    if (! @counts || $counts{$counts[0]} < 1) {
	my $cr = $sick->{object_option}{verbose} ? "\n" : "";
	die "${cr}File \"$source\": cannot guess character set\n";
    }
    $counts[0];
}

sub _int_size {
    my ($int) = @_;
    my $size = 0;
    my $fh = new Language::INTERCAL::GenericIO 'COUNT', 'r', \$size;
    $int->read($fh);
    $size;
}

1