File Coverage

blib/lib/Encode/RAD50.pm
Criterion Covered Total %
statement 63 65 96.9
branch 11 22 50.0
condition 6 7 85.7
subroutine 12 12 100.0
pod 3 3 100.0
total 95 109 87.1


line stmt bran cond sub pod time code
1             =head1 NAME
2              
3             Encode::RAD50 - Convert to and from the Rad50 character set.
4              
5             =head1 SYNOPSIS
6              
7             use Encode;
8             use Encode::RAD50; # Sorry about this.
9             $rad50 = encode ('RAD50', 'FOO');
10             $ascii = decode ('rad50', pack 'n', 10215);
11             binmode STDOUT, ':encoding(rad50)'; # Perverse, but it works.
12             print 'A#C'; # Gives a warning, since '#' isn't valid.
13              
14             Because this is not a standard encoding, you will need to explicitly
15              
16             use Encode::RAD50;
17              
18             Though of course the name of the module is case-sensitive, the name
19             of the encoding (passed to encode (), decode (), or ":encodingZ<>()")
20             is not case-sensitive.
21              
22             =head1 DESCRIPTION
23              
24             This package is designed to convert to and from the Rad50 character set.
25             It's really a piece of retrocomputing, since this character set was, to
26             the best of my knowledge, only used for the Digital (R.I.P.) PDP-11
27             computer, under (at least) the RSX-11 (including IAS and P/OS), RT-11,
28             RSTS (-11 and /E) operating systems.
29              
30             Rad50 is a way to squeeze three characters into two bytes, by
31             restricting the character set to upper-case 7-bit ASCII letters, digits,
32             space, "." and "$". There is also an encoding for what was called "the
33             illegal character." In the language of the Encode modules this is the
34             substitution character, and its ASCII representation is "?".
35              
36             When more than three characters are encoded, the first three go in the
37             first two bytes, the second three in the second two, and so on.
38              
39             If you try to encode some number of characters other than a multiple of
40             three, implicit spaces will be added to the right-hand end of the string.
41             These will become explicit when you decode.
42              
43             The astute observer will note that the character set does not have 50
44             characters. To which I reply that it does, if you count the invalid
45             character and if your "50" is octal.
46              
47             The test suite was verified using the RSX-11M+ "CVT" command. But the
48             CVT command interprets "A" as though it were "EEA" (i.e.
49             leading spaces), whereas this module interprets it as "AEE"
50             (i.e. trailing spaces).
51              
52             Nothing is actually exported by this package. The "encode" and "decode"
53             in the synopsis come from the L package.
54              
55             It is not clear to me that the PerlIO support is completely correct.
56             But the test suite passes under cygwin, darwin, MSWin32, and VMS (to
57             identify them by the contents of $^O).
58              
59             =head2 Methods
60              
61             The following methods should be considered public:
62              
63             =over 4
64              
65             =cut
66              
67             package Encode::RAD50;
68              
69 1     1   1287 use strict;
  1         1  
  1         26  
70 1     1   4 use warnings;
  1         2  
  1         26  
71              
72 1     1   392 use parent qw{ Encode::Encoding };
  1         257  
  1         4  
73              
74             our $VERSION = '0.018';
75              
76 1     1   62 use Carp;
  1         2  
  1         51  
77 1     1   4 use Encode qw{:fallback_all};
  1         2  
  1         175  
78              
79 1     1   6 use constant SUBSTITUTE => '?';
  1         2  
  1         82  
80 1     1   6 use constant RADIX => 40;
  1         1  
  1         44  
81 1     1   5 use constant MAX_WORD => RADIX * RADIX * RADIX;
  1         2  
  1         634  
82             # use constant CARP_MASK => WARN_ON_ERR | DIE_ON_ERR;
83              
84             __PACKAGE__->Define( 'RAD50' );
85              
86             my @r52asc = split '', ' ABCDEFGHIJKLMNOPQRSTUVWXYZ$.?0123456789';
87             my %irad50;
88             for (my $inx = 0; $inx < @r52asc; $inx++) {
89             $irad50{$r52asc[$inx]} = $inx;
90             }
91              
92             my $subs_value = $irad50{SUBSTITUTE ()};
93             delete $irad50{SUBSTITUTE ()};
94              
95             my $chk_mod = ~0; # Bits to mask in the check argument.
96              
97             # _carp ($check, ...)
98             # is a utility subroutine which croaks if the DIE_ON_ERR bit
99             # of $check is set, carps if WARN_ON_ERR is set (and it hasn't
100             # already croaked!), and returns true if RETURN_ON_ERR is set.
101             # It is not part of the public interface to this module, and the
102             # author reserves the right to do anything at all to it without
103             # telling anyone.
104              
105             sub _carp {
106 4     4   9 my ($check, @args) = @_;
107 4 50       10 $check & DIE_ON_ERR and croak @args;
108 4 50       5 $check & WARN_ON_ERR and carp @args;
109 4         11 return $check & RETURN_ON_ERR;
110             }
111              
112             =item $string = $object->decode ($octets, $check)
113              
114             This is the decode method documented in L. Though you
115             B call it directly, the anticipated mechanism is via the decode
116             subroutine exported by Encode.
117              
118             =cut
119              
120             # The Encode::Encoding documentation says that decode() SHOULD modify
121             # its $octets argument (the one after the invocant) if the $check
122             # argument is true. If perlio_ok() is true, SHOULD becomes MUST.
123             # Perl::Critic does not want us to do this, so we need to silence it.
124              
125             sub decode { ## no critic (RequireArgUnpacking)
126 18     18 1 7444 my ( undef, undef, $check ) = @_; # Invocant unused
127 18   100     53 $check ||= 0;
128 18         24 $check &= $chk_mod;
129 18         22 my $out = '';
130 18         31 while (length ($_[1])) {
131 18 50       49 my ($bits) = unpack length $_[1] > 1 ? 'n1' : 'C1', $_[1];
132 18 50       35 if ($bits < MAX_WORD) {
133 18         19 my $treble = '';
134 18         28 for (my $inx = 0; $inx < 3; $inx++) {
135 54         72 my $char = $bits % RADIX;
136 54         66 $bits = ($bits - $char) / RADIX;
137 54         63 $char = $r52asc[$char];
138 54 50 66     91 $char eq SUBSTITUTE and
139             _carp ($check, "'$char' is an invalid character.") and
140             return $out;
141 54         109 $treble = $char . $treble;
142             }
143 18         20 $out .= $treble;
144             } else {
145 0 0       0 _carp ($check, sprintf ("0x%04x is an invalid value", $bits))
146             and return $out;
147 0         0 $out .= SUBSTITUTE x 3;
148             }
149             } continue {
150 18         41 substr ($_[1], 0, 2, '');
151             }
152 18         45 return $out;
153             }
154              
155             =item $octets = $object->encode ($string, $check)
156              
157             This is the encode method documented in L. Though you
158             B call it directly, the anticipated mechanism is via the encode
159             subroutine exported by Encode.
160              
161             =cut
162              
163             # The Encode::Encoding documentation says that encode() SHOULD modify
164             # its $string argument (the one after $self) if the $check argument is
165             # true. If perlio_ok() is true, SHOULD becomes MUST. Perl::Critic does
166             # not want us to do this, so we need to silence it.
167              
168             # Note that we copy $_[1] into $string and pad it to a multiple of 3
169             # and work from that, because otherwise we get odd behavior on input
170             # that is not a multiple of 3. But we strip characters from the original
171             # argument as well.
172              
173             sub encode { ## no critic (RequireArgUnpacking)
174 18     18 1 8148 my ( undef, $string, $check ) = @_; # Invocant unused
175 18   100     53 $check ||= 0;
176 18         24 $check &= $chk_mod;
177 18 50       43 length ($string) % 3 and
178             $string .= ' ' x (3 - length ($string) % 3);
179 18         18 my @out;
180 18         34 while (length ($_[1])) {
181 18         20 my $bits = 0;
182 18         64 foreach my $char (split '', substr ($string, 0, 3, '')) {
183 54 100       77 if (exists $irad50{$char}) {
184 52         81 $bits = $bits * RADIX + $irad50{$char};
185             } else {
186 2 50       6 _carp ($check, "'$char' is an invalid character") and
187             return pack 'n*', @out;
188 2         4 $bits = $bits * RADIX + $subs_value;
189             }
190             }
191 18         32 push @out, $bits;
192             } continue {
193 18         42 substr ($_[1], 0, 3, '');
194             }
195 18         92 return pack 'n*', @out;
196             }
197              
198             =item $old_val = Encode::RAD50->silence_warnings ($new_val)
199              
200             This class method causes Encode::RAD50 to ignore the WARN_ON_ERR
201             flag. This is primarily for testing purposes, meaning that I couldn't
202             figure out any other way to suppress the warnings when testing the
203             handling of invalid characters in PerlIO.
204              
205             If the argument is true, warnings are not generated even if the caller
206             specifies the WARN_ON_ERROR flag. If the argument is false, warnings
207             are generated if the caller specifies WARN_ON_ERROR. Either way, the
208             previous value is returned.
209              
210             If no argument is passed, you get the current setting. The initial
211             setting is false.
212              
213             =cut
214              
215             sub silence_warnings {
216 1     1 1 1566 my $old = !($chk_mod & WARN_ON_ERR);
217 1 50       5 @_ and $chk_mod = $_[0] ?
    50          
218             $chk_mod & ~WARN_ON_ERR :
219             $chk_mod | WARN_ON_ERR;
220 1         2 return $old;
221             }
222              
223             1;
224              
225             __END__