Mercurial > repo
view interps/clc-intercal/CLC-INTERCAL-Base-1.-94.-2/INTERCAL/Rcfile.pm @ 3553:a2c0fbb7c2b1
<Roujo> revert
author | HackBot |
---|---|
date | Thu, 29 Aug 2013 20:30:48 +0000 |
parents | 859f9b4339e6 |
children |
line wrap: on
line source
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;