|
996
|
1 package Language::INTERCAL::Charset;
|
|
|
2
|
|
|
3 # Character sets
|
|
|
4
|
|
|
5 # This file is part of CLC-INTERCAL
|
|
|
6
|
|
|
7 # Copyright (c) 2006-2008 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 use strict;
|
|
|
14 use vars qw($VERSION $PERVERSION);
|
|
|
15 ($VERSION) = ($PERVERSION = "CLC-INTERCAL/Base INTERCAL/Charset.pm 1.-94.-2") =~ /\s(\S+)$/;
|
|
|
16
|
|
|
17 use Carp;
|
|
|
18 use Language::INTERCAL::Exporter '1.-94.-2';
|
|
|
19 use vars qw(@EXPORT @EXPORT_OK);
|
|
|
20 @EXPORT = ();
|
|
|
21 @EXPORT_OK = qw(fromascii toascii charset charset_default charset_name);
|
|
|
22
|
|
|
23 my @charsets;
|
|
|
24 my %charsets;
|
|
|
25 my $default;
|
|
|
26
|
|
|
27 BEGIN {
|
|
|
28 $default = 'ASCII';
|
|
|
29 @charsets = ( [$default, sub { shift }, sub { shift }] );
|
|
|
30 %charsets = ( $default => scalar(@charsets) );
|
|
|
31 }
|
|
|
32
|
|
|
33 use constant charset_default => $charsets{$default};
|
|
|
34
|
|
|
35 sub _find {
|
|
|
36 my ($how, $charset) = @_;
|
|
|
37 $charset =~ s/\s+//g;
|
|
|
38 if ($charset =~ /^\d+$/) {
|
|
|
39 $charset = charset_default if $charset == 0;
|
|
|
40 return undef if $charset < 1 || $charset > @charsets;
|
|
|
41 return $how ? $charset : $charsets[$charset - 1];
|
|
|
42 } else {
|
|
|
43 if (! exists $charsets{$charset}) {
|
|
|
44 eval "require Language::INTERCAL::Charset::$charset";
|
|
|
45 return undef if $@;
|
|
|
46 my ($to, $from);
|
|
|
47 eval {
|
|
|
48 no strict 'refs';
|
|
|
49 $to = \&{"Language::INTERCAL::Charset::${charset}::\L${charset}\E2ascii"};
|
|
|
50 &$to('');
|
|
|
51 $from = \&{"Language::INTERCAL::Charset::${charset}::ascii2\L${charset}\E"};
|
|
|
52 &$from('');
|
|
|
53 };
|
|
|
54 return undef if $@;
|
|
|
55 push @charsets, [$charset, $to, $from];
|
|
|
56 $charsets{$charset} = @charsets;
|
|
|
57 }
|
|
|
58 $charset = $charsets{$charset};
|
|
|
59 return $how ? $charset : $charsets[$charset - 1];
|
|
|
60 }
|
|
|
61 }
|
|
|
62
|
|
|
63 sub charset {
|
|
|
64 @_ == 1 or croak "Usage: charset(CHARSET)";
|
|
|
65 _find(1, @_);
|
|
|
66 }
|
|
|
67
|
|
|
68 sub charset_name {
|
|
|
69 @_ == 1 or croak "Usage: charset_name(CHARSET)";
|
|
|
70 my $charset = _find(0, @_);
|
|
|
71 defined $charset ? $charset->[0] : undef;
|
|
|
72 }
|
|
|
73
|
|
|
74 sub toascii {
|
|
|
75 @_ == 1 or croak "Usage: toascii(CHARSET)";
|
|
|
76 my $charset = _find(0, @_);
|
|
|
77 defined $charset ? $charset->[1] : undef;
|
|
|
78 }
|
|
|
79
|
|
|
80 sub fromascii {
|
|
|
81 @_ == 1 or croak "Usage: fromascii(CHARSET)";
|
|
|
82 my $charset = _find(0, @_);
|
|
|
83 defined $charset ? $charset->[2] : undef;
|
|
|
84 }
|
|
|
85
|
|
|
86 1;
|
