File Coverage

blib/lib/Convert/IBM390.pm
Criterion Covered Total %
statement 68 72 94.4
branch 16 28 57.1
condition 2 4 50.0
subroutine 11 11 100.0
pod 4 6 66.6
total 101 121 83.4


line stmt bran cond sub pod time code
1             package Convert::IBM390; # -*-perl-*-
2              
3 1     1   631 use strict;
  1         2  
  1         23  
4 1     1   4 use Carp;
  1         2  
  1         74  
5 1     1   4 use vars qw($VERSION @ISA @EXPORT @EXPORT_OK %EXPORT_TAGS);
  1         1  
  1         1013  
6              
7             require Exporter;
8              
9             @ISA = qw(Exporter);
10             @EXPORT = qw();
11             @EXPORT_OK = qw(asc2eb eb2asc eb2ascp packeb unpackeb
12             hexdump set_codepage set_translation);
13             $VERSION = '0.28';
14              
15             %EXPORT_TAGS = ( all => [ @EXPORT_OK ] );
16              
17             #------------ These tables are now defined in IBM390.xs.
18             #------------ Kept here for historical purposes only.
19             #my ($a2e_table, $e2a_table);
20             #$a2e_table = pack "H512",
21             # "00010203372d2e2f1605150b0c0d0e0f101112133c3d322618193f271c1d1e1f".
22             # "405a7f7b5b6c507d4d5d5c4e6b604b61f0f1f2f3f4f5f6f7f8f97a5e4c7e6e6f".
23             # "7cc1c2c3c4c5c6c7c8c9d1d2d3d4d5d6d7d8d9e2e3e4e5e6e7e8e9ade0bd5f6d".
24             # "79818283848586878889919293949596979899a2a3a4a5a6a7a8a9c04fd0a107".
25             # "202122232425061728292a2b2c090a1b30311a333435360838393a3b04143eff".
26             # "41aa4ab19fb26ab5bbb49a8ab0caafbc908feafabea0b6b39dda9b8bb7b8b9ab".
27             # "6465626663679e687471727378757677ac69edeeebefecbf80fdfefbfcbaae59".
28             # "4445424643479c4854515253585556578c49cdcecbcfcce170dddedbdc8d8edf";
29             #
30             #$e2a_table = pack "H512",
31             # "000102039c09867f978d8e0b0c0d0e0f101112139d0a08871819928f1c1d1e1f".
32             # "808182838485171b88898a8b8c050607909116939495960498999a9b14159e1a".
33             # "20a0e2e4e0e1e3e5e7f1a22e3c282b7c26e9eaebe8edeeefecdf21242a293b5e".
34             # "2d2fc2c4c0c1c3c5c7d1a62c255f3e3ff8c9cacbc8cdcecfcc603a2340273d22".
35             # "d8616263646566676869abbbf0fdfeb1b06a6b6c6d6e6f707172aabae6b8c6a4".
36             # "b57e737475767778797aa1bfd05bdeaeaca3a5b7a9a7b6bcbdbedda8af5db4d7".
37             # "7b414243444546474849adf4f6f2f3f57d4a4b4c4d4e4f505152b9fbfcf9faff".
38             # "5cf7535455565758595ab2d4d6d2d3d530313233343536373839b3dbdcd9da9f";
39             #------------ End of tables.
40              
41              
42             # Print an entire string in hexdump format, 32 bytes at a time
43             # (like a sysabend dump).
44             sub hexdump {
45 1     1 1 90 my ($String, $startad, $charset) = @_;
46 1   50     4 $startad ||= 0;
47 1   50     7 $charset ||= "ascii";
48 1         2 my ($i, $j, $d, $str, $pri, $hexes);
49 1         2 my @outlines = ();
50 1         2 my $L = length($String);
51             # Generate a printable version of the string.
52 1         2 my $pri_ex;
53 1 50       5 if ($charset =~ m/ebc/i) {
54 0         0 $pri_ex = '$pri = eb2ascp $str;';
55             } else {
56 1         2 $pri_ex = '($pri = $str) =~ tr/\\000-\\037\\177-\\377/ /;';
57             }
58 1         5 for ($i = 0; $i < $L; $i += 32) {
59 3         7 $str = substr($String, $i,32);
60             # Generate a printable version of the string.
61 3         183 eval $pri_ex;
62 3         11 $hexes = unpack("H64", $str);
63 3         5 $hexes =~ tr/a-f/A-F/;
64 3 100       9 if (($L - $i) < 32) { # Pad with blanks if necessary.
65 1         6 $pri = pack("A32", $pri);
66 1         3 $hexes = pack("A64", $hexes);
67             }
68 3         11 $d = sprintf("%06X: ", $startad + $i);
69 3         8 for ($j = 0; $j < 64; $j += 8) {
70 24         37 $d .= substr($hexes, $j, 8) . " ";
71 24 100       71 $d .= " " if $j == 24;
72             }
73 3         7 $d .= " *$pri*\n";
74 3         9 push @outlines, $d;
75             }
76 1         5 return @outlines;
77             }
78              
79             sub version {
80 1     1 1 47 return "Convert::IBM390 version $VERSION XS+C";
81             }
82              
83             #---------------------------------------------------------------------
84             # Use XSLoader if available, otherwise DynaLoader:
85              
86             eval {
87             require XSLoader;
88             XSLoader::load('Convert::IBM390', $VERSION);
89             1;
90             } or do {
91             require DynaLoader;
92             push @ISA, 'DynaLoader';
93             bootstrap Convert::IBM390 $VERSION;
94             };
95              
96             #---------------------------------------------------------- -*-perl-*-
97             # Code common to both XS and pure Perl versions:
98             #---------------------------------------------------------------------
99             # Validate mapping table (and 'pack' it if necessary):
100              
101             sub prepare_mapping {
102 6 100   6 0 15 return unless defined $_[0];
103              
104 2 50       6 return if length $_[0] == 256;
105              
106 2 50       23 unless ($_[0] =~ /[^0-9A-Fa-f\s]/) {
107 2         180 $_[0] =~ s/\s+//g; # Delete whitespace
108              
109 2 50       9 unless (length($_[0]) % 2) {
110 2         68 $_[0] = pack('H*', $_[0]);
111              
112 2 50       6 return if length $_[0] == 256;
113             } # end unless we have an odd number of digits
114             } # end unless string doesn't look like hexadecimal
115              
116 0         0 croak("$_[1] is not valid");
117             } # end prepare_mapping
118              
119             #---------------------------------------------------------------------
120             # Find the inverse of a mapping table (must be 1-to-1):
121              
122             sub invert_mapping {
123 2     2 0 41 my @orig = unpack('C256', $_[0]);
124              
125 2         30 my @new = (undef) x 256;
126              
127 2         6 foreach my $i (0 .. 255) {
128 512         559 $new[$orig[$i]] = $i;
129             }
130              
131 2 50       5 if (grep { not defined $_ } @new) {
  512         732  
132 0         0 croak("Translation is not 1-to-1;" .
133             " you must supply both ASCII->EBCDIC and EBCDIC->ASCII mappings");
134             }
135              
136 2         33 pack('C256', @new);
137             } # end invert_mapping
138              
139             #---------------------------------------------------------------------
140             # Set a user-specified translation table:
141              
142             sub set_translation {
143 2     2 1 5 my ($a2e_table, $e2a_table, $e2ap_table) = @_;
144              
145 2         6 prepare_mapping($a2e_table, 'ASCII->EBCDIC mapping');
146 2         4 prepare_mapping($e2a_table, 'EBCDIC->ASCII mapping');
147 2         5 prepare_mapping($e2ap_table, 'EBCDIC->printable ASCII mapping');
148              
149 2 50       3 if (not defined $a2e_table) {
    0          
150 2 50       5 croak("Neither ASCII->EBCDIC nor EBCDIC->ASCII mapping was defined")
151             unless defined $e2a_table;
152 2         5 $a2e_table = invert_mapping($e2a_table);
153             } elsif (not defined $e2a_table) {
154 0         0 $e2a_table = invert_mapping($a2e_table);
155             }
156              
157 2 50       6 if (not defined $e2ap_table) {
158 2         5 $e2ap_table = $e2a_table;
159 2         112 $e2ap_table =~ s/[^\w.<(+|&!\$*)\\;\-\/,\%>\?\`:#\@\'=\"~\[\]\{\}]/ /g;
160             }
161              
162 2         25 _set_translation($a2e_table, $e2a_table, $e2ap_table);
163             } # end set_translation
164              
165             #---------------------------------------------------------------------
166             sub set_codepage {
167 2     2 1 563 my $codepage = $_[0];
168              
169 1     1   666 eval "use Convert::IBM390::$codepage;";
  1     1   18  
  1         6  
  1         556  
  1         3  
  1         5  
  2         129  
170 2 50       9 croak "Unable to set code page $codepage: $@" if $@;
171             }
172              
173             #=====================================================================
174             1;
175              
176             __END__