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

package Language::INTERCAL::Rcfile;

# Configuration files for sick and intercalc

# 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/Rcfile.pm 1.-94.-2") =~ /\s(\S+)$/;

use Carp;
use File::Spec::Functions;
use Language::INTERCAL::Exporter '1.-94.-2';
use Language::INTERCAL::GenericIO '1.-94.-2';

my %rcdefs = (
    'WRITE' => [ \&_rc_array, [], 'Character sets used for guessing' ],
    'UNDERSTAND' => [ \&_rc_understand, [], 'Suffix to parser mapping' ],
    'UNDERSTAND ANYWHERE' => [ \&_rc_anywhere, [], undef ],
    'SPEAK' => [ \&_rc_array, [], 'Default user interfaces' ],
    'PRODUCE' => [ \&_rc_scalar, '', 'Default compiler back end' ],
);

my %programs = (
    INTERNET      => 'INTERNET defaults',
    INTERCALC     => "Calculator's defaults",
);

sub new {
    @_ == 1 or croak "Usage: new Language::INTERCAL::Rcfile";
    my ($class) = @_;
    my %data = ();
    for my $k (keys %rcdefs) {
	$data{$k} = ref $rcdefs{$k}[1] ? [] : '';
    }
    my @include =
	grep { -d $_ }
	     map { catdir($_, qw(Language INTERCAL Include)) }
		 @INC;
    # TODO - make the following portable (is there such a thing?)
    my @home = ();
    if ($ENV{HOME}) {
	@home = (homedir => $ENV{HOME});
    } else {
	my $name = getlogin;
	if (! $name || ! getpwnam($name)) {
	    $name = getpwuid($<);
	}
	if ($name && getpwnam($name)) {
	    @home = (homedir => (getpwnam($name))[7]);
	}
    }
    bless {
	options => {
	    rcfile => [],
	    include => \@include,
	    nouserrc => 0,
	},
	userinc => 0,
	rccmd => [],
	data => \%data,
	prog => {},
	@home,
    }, $class;
}

sub setoption {
    @_ == 3 or croak "Usage: RCFILE->setoption(NAME, VALUE)";
    my ($rc, $name, $value) = @_;
    exists $rc->{options}{$name}
	or die "Unknown option $name\n";
    if (ref $rc->{options}{$name}) {
	if ($name eq 'include') {
	    my $userinc = $rc->{userinc}++;
	    splice(@{$rc->{options}{$name}}, $userinc, 0, $value);
	} else {
	    push @{$rc->{options}{$name}}, $value;
	}
    } else {
	$rc->{options}{$name} = $value;
    }
    $rc;
}

sub getoption {
    @_ == 2 or croak "Usage: RCFILE->getoption(NAME)";
    my ($rc, $name) = @_;
    exists $rc->{options}{$name}
	or die "Unknown option $name\n";
    $rc->{options}{$name};
}

sub getitem {
    @_ == 2 or croak "Usage: RCFILE->getitem(NAME)";
    my ($rc, $name) = @_;
    exists $rc->{data}{$name}
	or die "Unknown item $name\n";
    ref $rc->{data}{$name} or return $rc->{data}{$name};
    @{$rc->{data}{$name}};
}

sub putitem {
    @_ == 3 or croak "Usage: RCFILE->putitem(NAME, VALUE)";
    my ($rc, $name, $value) = @_;
    exists $rc->{data}{$name}
	or die "Unknown item $name\n";
    if (ref $rc->{data}{$name}) {
	ref $value && UNIVERSAL::isa($value, 'ARRAY')
	    or die "Value for $name should be an array\n";
    } else {
	ref $value
	    and die "Value for $name should be a scalar\n";
    }
    $rc->{data}{$name} = $value;
    $rc;
}

sub program_options {
    @_ == 2 or croak "Usage: RCFILE->program_options(PROGRAM)";
    my ($rc, $program) = @_;
    $program = uc($program);
    exists $rc->{prog}{$program} or return ();
    %{$rc->{prog}{$program}};
}

sub program_setoptions {
    @_ == 3 or croak "Usage: RCFILE->program_setoptions(PROGRAM, OPTIONS)";
    my ($rc, $program, $options) = @_;
    ref $options && UNIVERSAL::isa($options, 'HASH')
	or die "Options should be a HASH reference\n";
    $program = uc($program);
    $rc->{prog}{$program} = $options;
    $rc;
}

sub _rc_array {
    my ($rc, $mode, $ln, $file) = @_;
    die "Missing value for $mode\n" if $ln eq '';
    push @{$rc->{data}{$mode}}, $ln;
}

sub _rc_scalar {
    my ($rc, $mode, $ln, $file) = @_;
    die "Missing value for $mode\n" if $ln eq '';
    $rc->{data}{$mode} = $ln;
}

sub _rc_understand {
    my ($rc, $mode, $ln, $file) = @_;
    my $suffix;
    if ($ln =~ s/^(['"])(.*?)\1\s*//) {
	$suffix = $2;
    } elsif ($ln =~ s/^(\S+)\s*//) {
	$suffix = $1;
    } else {
	die "$file\: Invalid $mode\: missing SUFFIX\n";
    }
    if ($ln =~ s/^ANYWHERE\s*//i) {
	$mode .= ' ANYWHERE';
	$ln = $suffix . ' ' . $ln;
	return &{$rcdefs{$mode}[0]}($rc, $mode, $ln, $file);
    }
    $ln =~ s/^AS\s*//i or die "$file\: Invalid $mode\: missing AS\n";
    my $name;
    if ($ln =~ s/^(['"])(.*?)\1\s*//) {
	$name = $2;
    } elsif ($ln =~ s/^(\w+)\s*//) {
	$name = $1;
    } else {
	die "$file\: Invalid $mode\: missing NAME\n";
    }
    my %map = ( '' => [] );
    while ($ln ne '') {
	if ($ln =~ s/^WITH\s*//i) {
	    while (1) {
		my $maybe = '';
		$maybe = $1 if $ln =~ s/^(\?)//;
		my $preload;
		if ($ln =~ s/^(['"])(.*?)\1\s*//) {
		    $preload = $2;
		} elsif ($ln =~ s/^(\w+)\s*//) {
		    $preload = $1;
		} else {
		    die "$file\: Invalid $mode\: missing PRELOAD\n";
		}
		push @{$map{''}}, $maybe . $preload;
		$ln =~ s/^\+\s*// or last;
	    }
	    next;
	}
	if ($ln =~ s/^DISCARDING\s*//) {
	    my $option;
	    if ($ln =~ s/^(['"])(.*?)\1\s*//) {
		$option = $2;
	    } elsif ($ln =~ s/^(\S+)\s*//) {
		$option = $1;
	    } else {
		die "$file\: Invalid $mode\: missing DISCARDING\n";
	    }
	    $map{$option} = [[], ''];
	    next;
	}
	die "$file\: Invalid $mode\: $ln\n";
    }
    if ($suffix =~ s/^\.\.([^\.]+)\.//) {
	# special item used for program configuration - this avoids changing
	# the syntax of .sickrc again
	$rc->{prog}{uc $1}{$suffix} = [$name, \%map];
    } else {
	push @{$rc->{data}{$mode}}, [$suffix, $name, \%map];
    }
}

sub _rc_anywhere {
    my ($rc, $mode, $ln, $file) = @_;
    my $suffix;
    if ($ln =~ s/^(['"])(.*?)\1\s*//) {
	$suffix = $2;
    } elsif ($ln =~ s/^(\S+)\s*//) {
	$suffix = $1;
    } else {
	die "$file\: Invalid $mode\: missing SUFFIX\n";
    }
    $ln =~ s/^AS\s*//i or die "$file\: Invalid $mode\: missing AS\n";
    my $name;
    if ($ln =~ s/^(['"])(.*?)\1\s*//) {
	$name = $2;
    } elsif ($ln =~ s/^(\w+)\s*//) {
	$name = $1;
    } else {
	die "$file\: Invalid $mode\: missing NAME\n";
    }
    $ln =~ s/^WITH\s*//i or die "$file\: Invalid $mode\: missing WITH\n";
    my @preload = ();
    while (1) {
	my $maybe = '';
	$maybe = $1 if $ln =~ s/^(\?)//;
	my $preload;
	if ($ln =~ s/^(['"])(.*?)\1\s*//) {
	    $preload = $2;
	} elsif ($ln =~ s/^(\S+)\s*//) {
	    $preload = $1;
	} else {
	    die "$file\: Invalid $mode\: missing PRELOAD\n";
	}
	push @preload, $maybe . $preload;
	$ln =~ s/^\+\s*// or last;
    }
    die "$file\: Invalid $mode\: extra data at end ($ln)\n"
	if $ln ne '';
    push @{$rc->{data}{$mode}}, [$suffix, \@preload, $name];
}

sub load {
    @_ == 1 or croak "Usage: RCFILE->load";
    my ($rc) = @_;
    unless (@{$rc->{options}{rcfile}}) {
	my @home = exists $rc->{homedir} ? ($rc->{homedir}) : ();
	my $u = $rc->{options}{nouserrc};
	$rc->{options}{rcfile} = [
	    map {canonpath($_)}
		grep { -f $_ }
		     map { catfile($_, "system.sickrc"),
			   ($u ? () : catfile($_, ".sickrc")),
			 }
			 (@{$rc->{options}{include}}, @home, '.')
	];
	$rc->{options}{rcfile} = [$rc->{options}{rcfile}[0]]
	    if $u && @{$rc->{options}{rcfile}} > 1;
    }
    for my $rcfile (@{$rc->{options}{rcfile}}) {
	my $fh = Language::INTERCAL::GenericIO->new('FILE', 'w', $rcfile)
	    or die "$rcfile: $!\n";
	my $mode = undef;
	my $text = '';
	my $mln = '';
	my $no = 0;
	while ('' ne (my $ln = $fh->write_text())) {
	    chomp $ln;
	    $ln =~ s/^\s*//;
	    $no++;
	    next if $ln eq '';
	    my $rn = "$rcfile\:$no";
	    if ($ln =~ s/^(?:DO|PLEASE)\s*NOTE\s*//i) {
		&{$rcdefs{$mode}[0]}($rc, $mode, $text, $mln)
		    if defined $mode && $mode ne '';
		$mode = '';
	    } elsif ($ln =~ s/^I\s*DO\s*N[O']T\s*(\S+)//i) {
		&{$rcdefs{$mode}[0]}($rc, $mode, $text, $mln)
		    if defined $mode && $mode ne '';
		$mode = uc($1);
		die "No such action \"$1\": $rn\n"
		    unless exists $rcdefs{$mode};
		die "Invalid declaration \"$_\": $rn\n"
		    unless ref $rc->{data}{$mode};
		$rc->{data}{$mode} = [];
		$mode = undef;
	    } elsif ($ln =~ s/^I\s*CAN\s*(\S+)\s*//i) {
		&{$rcdefs{$mode}[0]}($rc, $mode, $text, $mln)
		    if defined $mode && $mode ne '';
		$mode = uc($1);
		exists $rcdefs{$mode}
		    or die "No such action \"$1\": $rn\n";
		$text = $ln;
		$mln = $rn;
	    } elsif (defined $mode) {
		$text .= ' ' . $ln;
	    } else {
		die "Syntax error: $rn\n";
	    }
	}
	&{$rcdefs{$mode}[0]}($rc, $mode, $text, $mln)
	    if defined $mode && $mode ne '';
    }
    $rc;
}

sub save {
    @_ == 1 || @_ == 2 or croak "Usage: RCFILE->save [(TO)]";
    my ($rc, $to) = @_;
    if (! defined $to) {
	$to = catfile($rc->{homedir}, ".sickrc"),
    }
    my $tmp = $to . '.tmp';
    open(RC, '>', $tmp) or die "$tmp: $!\n";
    print RC "PLEASE NOTE: This file was automatically generated while saving settings\n\n"
	or die "$tmp: $!\n";
    for my $data (sort keys %{$rc->{data}}) {
	print RC "PLEASE NOTE: $rcdefs{$data}[2]\n" or die "$tmp: $!\n"
	    if defined $rcdefs{$data}[2];
	if (ref $rc->{data}{$data}) {
	    print RC "I DON'T $data\n" or die "$tmp: $!\n"
		if defined $rcdefs{$data}[2];
	    for my $value (@{$rc->{data}{$data}}) {
		if ($data eq 'UNDERSTAND') {
		    my ($suffix, $name, $map) = @$value;
		    $value = "$suffix\n\tAS \"$name\"";
		    my @w = map {
			if (/\s/) {
			    if (/"/) {
				"'$_'";
			    } else {
				"\"$_\"";
			    }
			} else {
			    $_;
			}
		    } @{$map->{''}};
		    $value .= "\n\tWITH " . join(' + ', @w);
		    $value .= "\n\tDISCARDING " . join(' + ', sort grep { /./ } keys %$map)
			if keys %$map > 1;
		} elsif ($data eq 'UNDERSTAND ANYWHERE') {
		    my ($suffix, $preload, $name) = @$value;
		    $value = "$suffix\n\tAS \"$name\"";
		    if (@$preload) {
			my @p = map {
			    if (/\s/) {
				if (/"/) {
				    "'$_'";
				} else {
				    "\"$_\"";
				}
			    } else {
				$_;
			    }
			} @$preload;
			$value .= "\n\tWITH " . join(' ', @p);
		    }
		} elsif ($data =~ /\s/) {
		    if ($data =~ /"/) {
			$data = "'$data'";
		    } else {
			$data = "\"$data\"";
		    }
		}
		print RC "I CAN $data $value\n" or die "$tmp: $!\n";
	    }
	} else {
	    print RC "I CAN $data $rc->{data}{$data}\n" or die "$tmp: $!\n";
	}
	print RC "\n" or die "$tmp: $!\n";
    }
    for my $data (sort keys %{$rc->{prog}}) {
	my $def = $programs{uc $data} || "Defaults for \L$data";
	print RC "PLEASE NOTE: $def\n" or die "$tmp: $!\n";
	for my $key (sort keys %{$rc->{prog}{$data}}) {
	    my ($value, $map) = @{$rc->{prog}{$data}{$key}};
	    my $withr = $map->{''};
	    my $with = $withr && @$withr ? join(' ', ' WITH', map { "\"$_\"" } @$withr) : '';
	    print RC "I CAN UNDERSTAND \"$data.$key\" AS \"$value\"$with\n" or die "$tmp: $!\n";
	}
	print RC "\n" or die "$tmp: $!\n";
    }
    close RC or die "$tmp: $!\n";
    my $old = $to . '~';
    unlink($old);
    rename($to, $old);
    rename($tmp, $to) or die "rename($tmp, $to): $!\n";
    $rc;
}

sub run {
    @_ == 2 or croak "Usage: RCFILE->run(UI)";
    my ($rc, $ui) = @_;
    for my $cmdline (@{$rc->{rccmd}}) {
	$ui->do($cmdline);
    }
    $rc;
}

1;