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

<Gregor> tar xf egobot.tar.xz
author HackBot
date Sun, 09 Dec 2012 19:30:08 +0000
parents
children
line wrap: on
line diff
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/interps/clc-intercal/CLC-INTERCAL-Base-1.-94.-2/INTERCAL/Charset.pm	Sun Dec 09 19:30:08 2012 +0000
@@ -0,0 +1,86 @@
+package Language::INTERCAL::Charset;
+
+# Character sets
+
+# 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/Charset.pm 1.-94.-2") =~ /\s(\S+)$/;
+
+use Carp;
+use Language::INTERCAL::Exporter '1.-94.-2';
+use vars qw(@EXPORT @EXPORT_OK);
+@EXPORT = ();
+@EXPORT_OK = qw(fromascii toascii charset charset_default charset_name);
+
+my @charsets;
+my %charsets;
+my $default;
+
+BEGIN {
+    $default = 'ASCII';
+    @charsets = ( [$default, sub { shift }, sub { shift }] );
+    %charsets = ( $default => scalar(@charsets) );
+}
+
+use constant charset_default => $charsets{$default};
+
+sub _find {
+    my ($how, $charset) = @_;
+    $charset =~ s/\s+//g;
+    if ($charset =~ /^\d+$/) {
+	$charset = charset_default if $charset == 0;
+	return undef if $charset < 1 || $charset > @charsets;
+	return $how ? $charset : $charsets[$charset - 1];
+    } else {
+	if (! exists $charsets{$charset}) {
+	    eval "require Language::INTERCAL::Charset::$charset";
+	    return undef if $@;
+	    my ($to, $from);
+	    eval {
+		no strict 'refs';
+		$to = \&{"Language::INTERCAL::Charset::${charset}::\L${charset}\E2ascii"};
+		&$to('');
+		$from = \&{"Language::INTERCAL::Charset::${charset}::ascii2\L${charset}\E"};
+		&$from('');
+	    };
+	    return undef if $@;
+	    push @charsets, [$charset, $to, $from];
+	    $charsets{$charset} = @charsets;
+	}
+	$charset = $charsets{$charset};
+	return $how ? $charset : $charsets[$charset - 1];
+    }
+}
+
+sub charset {
+    @_ == 1 or croak "Usage: charset(CHARSET)";
+    _find(1, @_);
+}
+
+sub charset_name {
+    @_ == 1 or croak "Usage: charset_name(CHARSET)";
+    my $charset = _find(0, @_);
+    defined $charset ? $charset->[0] : undef;
+}
+
+sub toascii {
+    @_ == 1 or croak "Usage: toascii(CHARSET)";
+    my $charset = _find(0, @_);
+    defined $charset ? $charset->[1] : undef;
+}
+
+sub fromascii {
+    @_ == 1 or croak "Usage: fromascii(CHARSET)";
+    my $charset = _find(0, @_);
+    defined $charset ? $charset->[2] : undef;
+}
+
+1;