Mercurial > repo

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

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
<Gregor> tar xf egobot.tar.xz
author HackBot
date Sun, 09 Dec 2012 19:30:08 +0000
parents
children
comparison
equal deleted inserted replaced
995:6883f5911eb7 996:859f9b4339e6
1 package Language::INTERCAL::Charset::Baudot;
2
3 # Convert between Baudot and ASCII
4
5 # This file is part of CLC-INTERCAL.
6
7 # Copyright (C) 1999, 2000, 2002, 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/Baudot.pm 1.-94.-2") =~ /\s(\S+)$/;
16
17 use Carp;
18 use Language::INTERCAL::Exporter '1.-94.-2';
19 use Language::INTERCAL::Splats '1.-94.-2', qw(:SP);
20 use vars qw(@EXPORT @EXPORT_OK);
21 @EXPORT = ();
22 @EXPORT_OK = qw(ascii2baudot baudot2ascii);
23
24 my @charset = (
25 "\000E\nA SIU\rDRJNFCKTZWLHYPQOBG2MXV1",
26 "\000e\na siu\rdrjnfcktzwlhypqobg2mxv1",
27 "\0003\n- \a87\r\$4',!:(5\")2 6019?&3./;0",
28 "\000\242\n+\t\\#=\r*{~\245|^<[}>]\b@\253\243\254\377\2613%_\2730",
29 );
30
31 my $charset = join('', map { "\000" . substr($_, 1, 26) .
32 "\000" . substr($_, 28, 3) . "\000" }
33 @charset);
34 push @charset, '';
35
36 sub baudot2ascii {
37 @_ == 1 or croak "Usage: baudot2ascii(STRING)";
38 my $string = shift;
39 my $set = 0;
40 my $result = '';
41 while ($string ne '') {
42 my $chr = ord($string) & 037;
43 $string = substr($string, 1);
44 if ($chr == 033 || $chr == 037) {
45 $set = ord(substr($charset[$set], $chr, 1)) & 03;
46 } else {
47 $result .= substr($charset[$set], $chr, 1);
48 }
49 }
50 $result;
51 }
52
53 sub ascii2baudot {
54 @_ == 1 or @_ == 2 or croak "Usage: ascii2baudot(STRING)";
55 my $string = shift;
56 my $faint = @_ ? shift : 1;
57 my $set = 4;
58 my $result = '';
59 while ($string ne '') {
60 my $chr = substr($string, 0, 1);
61 $string = substr($string, 1);
62 my $pos = index($charset[$set], $chr);
63 if ($pos < 0 || $pos == 033 || $pos == 037) {
64 $pos = index($charset, $chr);
65 if ($pos < 0 || $chr eq "\000") {
66 faint(SP_NOSUCHCHAR, ord($chr), "Baudot") if $faint;
67 $string = sprintf("\\%03o", ord($chr)) . $string;
68 next;
69 }
70 my $s = $pos >> 5;
71 $pos = $pos & 037;
72 if ($set > 3) {
73 $result .= ['[_', '__', '_[', '[[']->[$s];
74 } else {
75 $result .= ['', '_', '[', '[[',
76 '[_', '', '[', '[[',
77 '_', '__', '', '[[',
78 '_', '__', '_[', '',
79 ]->[($set << 2) | $s];
80 }
81 $set = $s;
82 }
83 $result .= sprintf("%c", 0x40 + $pos);
84 }
85 $result;
86 }
87
88 1;
89
90 __END__
91
92 =head1 NAME
93
94 Charset::Baudot - allows to use Baudot string constants in ASCII programs (and v.v.)
95
96 =head1 SYNOPSIS
97
98 use Charset::Baudot 'baudot2ascii';
99
100 my $a = baudot2ascii"(Baudot text)";
101
102 =head1 DESCRIPTION
103
104 I<Charset::Baudot> defines functions to convert between a subset of ASCII and a
105 subset of nonstandard Baudot - the original Baudot allows only letters,
106 numbers, and some punctuation. We assume that a "Shift to letters" code
107 while already in letters mode means "Shift to lowercase" and "Shift to
108 figures" while already in figures mode means "Shift to symbols". This allows
109 to use up to 120 characters. However, for simplicity some characters are
110 available in multiple sets, so the total is less than that.
111
112 Two functions, I<baudot2ascii> and I<ascii2baudot>, are exportable (but
113 not exported by default). They do the obvious thing to their first argument
114 and return the transformed string.
115
116 =head1 BAUDOT CHARACTER TABLE
117
118 The following are the characters recognised. As described, the "shift"
119 characters have nonstandard meaning.
120
121 set Letters Lowercase Figures Symbols
122 code
123 00 N/A N/A N/A N/A
124 01 E e 3 Cents
125 02 L/F L/F L/F L/F (line feed)
126 03 A a - +
127 04 Space Space Space Tab
128 05 S s BELL \
129 06 I i 8 #
130 07 U u 7 =
131 08 C/R C/R C/R C/R (carriage return)
132 09 D d $ *
133 10 R r 4 {
134 11 J j ' ~
135 12 N n , XOR
136 13 F f ! |
137 14 C c : ^
138 15 K k ( <
139 16 T t 5 [
140 17 Z z " }
141 18 W w ) >
142 19 L l 2 ]
143 20 H h N/A backspace
144 21 Y y 6 @
145 22 P p 0 N/A
146 23 Q q 1 POUND
147 24 O o 9 NOT
148 25 B b ? delete
149 26 G g & N/A
150 27 Figures Figures Symbols Symbols
151 28 M m . %
152 29 X x / _
153 30 V v ; N/A
154 31 Lowercase Lowercase Letters Letters
155
156 =head1 COPYRIGHT
157
158 This module is part of CLC-INTERCAL.
159
160 Copyright (C) 1999, 2000, 2002, 2006, 2007 Claudio Calvelli, all rights reserved
161
162 See files README and COPYING in the distribution for information.
163
164 =head1 SEE ALSO
165
166 A qualified psychiatrist.
167