X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=pod%2Fperlebcdic.pod;h=86dcba29a5444dd84d93de65eb58e2b0efb15675;hb=ba370e9b8a212c313d985163053c7ed938fcae22;hp=be2a2e3d8ca19ba54ae07ddb70c4b02daf382289;hpb=769c28980682c9f2c20f6c60950b1b28469d23fa;p=p5sagit%2Fp5-mst-13.2.git diff --git a/pod/perlebcdic.pod b/pod/perlebcdic.pod index be2a2e3..86dcba2 100644 --- a/pod/perlebcdic.pod +++ b/pod/perlebcdic.pod @@ -130,29 +130,8 @@ work with a pod2_other_format translation) through: =back - perldoc -m perlebcdic | \ - perl -ne 'if(/(.{33})(\d+)\s+(\d+)\s+(\d+)\s+(\d+)/)' \ - -e '{printf("%s%-9o%-9o%-9o%o\n",$1,$2,$3,$4,$5)}' - -Or, as a script, called like C: - - my $regex = qr/ - (.{33}) # any 33 characters - - (\d+)\s+ # capture some digits, discard spaces - (\d+)\s+ # ".." - (\d+)\s+ # ".." - (\d+) # capture some digits - /x; - - while ( <> ) { - if ( $_ =~ $regex ) { - printf( - "%s%-9o%-9o%-9o%o\n", - $1, $2, $3, $4, $5, - ); - } - } + perl -ne 'if(/(.{33})(\d+)\s+(\d+)\s+(\d+)\s+(\d+)/)' \ + -e '{printf("%s%-9o%-9o%-9o%o\n",$1,$2,$3,$4,$5)}' perlebcdic.pod If you want to retain the UTF-x code points then in script form you might want to write: @@ -163,47 +142,20 @@ might want to write: =back - my $regex = qr/ - (.{33}) # $1: any 33 characters - - (\d+)\s+ # $2, $3, $4, $5: - (\d+)\s+ # capture some digits, discard spaces - (\d+)\s+ # 4 times - (\d+)\s+ - - (\d+) # $6: capture some digits, - \.? # there may be a period, - (\d*) # $7: capture some digits if they're there, - \s+ # discard spaces - - (\d+) # $8: capture some digits - \.? # there may be a period, - (\d*) # $9: capture some digits if they're there, - /x; - - open( FH, 'perldoc -m perlebcdic |' ) || - die "Could not open perlebcdic.pod: $!"; - while ( ) { - if ( $_ =~ $regex ) { - if ( $7 ne '' && $9 ne '' ) { - printf( - "%s%-9o%-9o%-9o%-9o%-3o.%-5o%-3o.%o\n", - $1, $2, $3, $4, $5, $6, $7, $8, $9 - ); - } elsif ( $7 ne '' ) { - printf( - "%s%-9o%-9o%-9o%-9o%-3o.%-5o%o\n", - $1, $2, $3, $4, $5, $6, $7, $8 - ); - } else { - printf( - "%s%-9o%-9o%-9o%-9o%-9o%o\n", - $1, $2, $3, $4, $5, $6, $8 - ); + open(FH,") { + if (/(.{33})(\d+)\s+(\d+)\s+(\d+)\s+(\d+)\s+(\d+)\.?(\d*)\s+(\d+)\.?(\d*)/) { + if ($7 ne '' && $9 ne '') { + printf("%s%-9o%-9o%-9o%-9o%-3o.%-5o%-3o.%o\n",$1,$2,$3,$4,$5,$6,$7,$8,$9); + } + elsif ($7 ne '') { + printf("%s%-9o%-9o%-9o%-9o%-3o.%-5o%o\n",$1,$2,$3,$4,$5,$6,$7,$8); + } + else { + printf("%s%-9o%-9o%-9o%-9o%-9o%o\n",$1,$2,$3,$4,$5,$6,$8); } } } - close FH; If you would rather see this table listing hexadecimal values then run the table through: @@ -214,9 +166,8 @@ run the table through: =back - perldoc -m perlebcdic | \ - perl -ne 'if(/(.{33})(\d+)\s+(\d+)\s+(\d+)\s+(\d+)/)' \ - -e '{printf("%s%-9X%-9X%-9X%X\n",$1,$2,$3,$4,$5)}' + perl -ne 'if(/(.{33})(\d+)\s+(\d+)\s+(\d+)\s+(\d+)/)' \ + -e '{printf("%s%-9X%-9X%-9X%X\n",$1,$2,$3,$4,$5)}' perlebcdic.pod Or, in order to retain the UTF-x code points in hexadecimal: @@ -226,50 +177,21 @@ Or, in order to retain the UTF-x code points in hexadecimal: =back - my $regex = qr/ - (.{33}) # $1: any 33 characters - - (\d+)\s+ # $2, $3, $4, $5: - (\d+)\s+ # capture some digits, discard spaces - (\d+)\s+ # 4 times - (\d+)\s+ - - (\d+) # $6: capture some digits, - \.? # there may be a period, - (\d*) # $7: capture some digits if they're there, - \s+ # discard spaces - - (\d+) # $8: capture some digits - \.? # there may be a period, - (\d*) # $9: capture some digits if they're there, - /x; - - open( FH, 'perldoc -m perlebcdic |' ) || - die "Could not open perlebcdic.pod: $!"; + open(FH,") { - if ( $_ =~ $regex ) { - if ( $7 ne '' && $9 ne '' ) { - printf( - "%s%-9X%-9X%-9X%-9X%-2X.%-6X%-2X.%X\n", - $1, $2, $3, $4, $5, $6, $7, $8, $9 - ); + if (/(.{33})(\d+)\s+(\d+)\s+(\d+)\s+(\d+)\s+(\d+)\.?(\d*)\s+(\d+)\.?(\d*)/) { + if ($7 ne '' && $9 ne '') { + printf("%s%-9X%-9X%-9X%-9X%-2X.%-6X%-2X.%X\n",$1,$2,$3,$4,$5,$6,$7,$8,$9); } - elsif ( $7 ne '' ) { - printf( - "%s%-9X%-9X%-9X%-9X%-2X.%-6X%X\n", - $1, $2, $3, $4, $5, $6, $7, $8 - ); + elsif ($7 ne '') { + printf("%s%-9X%-9X%-9X%-9X%-2X.%-6X%X\n",$1,$2,$3,$4,$5,$6,$7,$8); } else { - printf( - "%s%-9X%-9X%-9X%-9X%-9X%X\n", - $1, $2, $3, $4, $5, $6, $8 - ); + printf("%s%-9X%-9X%-9X%-9X%-9X%X\n",$1,$2,$3,$4,$5,$6,$8); } } } -=head2 THE SINGLE OCTET TABLE incomp- incomp- 8859-1 lete lete @@ -532,7 +454,6 @@ Or, in order to retain the UTF-x code points in hexadecimal: 254 142 142 142 195.190 139.114 255 223 223 223 195.191 139.115 - If you would rather see the above table in CCSID 0037 order rather than ASCII + Latin-1 order then run the table through: @@ -542,12 +463,11 @@ ASCII + Latin-1 order then run the table through: =back - perldoc -m perlebcdic | \ - perl -ne 'if(/.{33}\d{1,3}\s{6,8}\d{1,3}\s{6,8}\d{1,3}\s{6,8}\d{1,3}/)' \ - -e '{push(@l,$_)}' \ - -e 'END{print map{$_->[0]}' \ - -e 'sort{$a->[1] <=> $b->[1]}' \ - -e 'map{[$_,substr($_,42,3)]}@l;}' + perl -ne 'if(/.{33}\d{1,3}\s{6,8}\d{1,3}\s{6,8}\d{1,3}\s{6,8}\d{1,3}/)'\ + -e '{push(@l,$_)}' \ + -e 'END{print map{$_->[0]}' \ + -e ' sort{$a->[1] <=> $b->[1]}' \ + -e ' map{[$_,substr($_,42,3)]}@l;}' perlebcdic.pod If you would rather see it in CCSID 1047 order then change the digit 42 in the last line to 51, like this: @@ -558,12 +478,11 @@ If you would rather see it in CCSID 1047 order then change the digit =back - perldoc -m perlebcdic | \ - perl -ne 'if(/.{33}\d{1,3}\s{6,8}\d{1,3}\s{6,8}\d{1,3}\s{6,8}\d{1,3}/)' \ - -e '{push(@l,$_)}' \ - -e 'END{print map{$_->[0]}' \ - -e 'sort{$a->[1] <=> $b->[1]}' \ - -e 'map{[$_,substr($_,51,3)]}@l;}' + perl -ne 'if(/.{33}\d{1,3}\s{6,8}\d{1,3}\s{6,8}\d{1,3}\s{6,8}\d{1,3}/)'\ + -e '{push(@l,$_)}' \ + -e 'END{print map{$_->[0]}' \ + -e ' sort{$a->[1] <=> $b->[1]}' \ + -e ' map{[$_,substr($_,51,3)]}@l;}' perlebcdic.pod If you would rather see it in POSIX-BC order then change the digit 51 in the last line to 60, like this: @@ -574,12 +493,11 @@ If you would rather see it in POSIX-BC order then change the digit =back - perldoc -m perlebcdic | \ - perl -ne 'if(/.{33}\d{1,3}\s{6,8}\d{1,3}\s{6,8}\d{1,3}\s{6,8}\d{1,3}/)' \ - -e '{push(@l,$_)}' \ - -e 'END{print map{$_->[0]}' \ - -e 'sort{$a->[1] <=> $b->[1]}' \ - -e 'map{[$_,substr($_,60,3)]}@l;}' + perl -ne 'if(/.{33}\d{1,3}\s{6,8}\d{1,3}\s{6,8}\d{1,3}\s{6,8}\d{1,3}/)'\ + -e '{push(@l,$_)}' \ + -e 'END{print map{$_->[0]}' \ + -e ' sort{$a->[1] <=> $b->[1]}' \ + -e ' map{[$_,substr($_,60,3)]}@l;}' perlebcdic.pod =head1 IDENTIFYING CHARACTER CODE SETS @@ -588,44 +506,44 @@ To determine the character set you are running under from perl one could use the return value of ord() or chr() to test one or more character values. For example: - my $is_ascii = "A" eq chr(65); - my $is_ebcdic = "A" eq chr(193); + $is_ascii = "A" eq chr(65); + $is_ebcdic = "A" eq chr(193); Also, "\t" is a C character so that: - my $is_ascii = ord("\t") == 9; - my $is_ebcdic = ord("\t") == 5; + $is_ascii = ord("\t") == 9; + $is_ebcdic = ord("\t") == 5; To distinguish EBCDIC code pages try looking at one or more of the characters that differ between them. For example: - my $is_ebcdic_37 = "\n" eq chr(37); - my $is_ebcdic_1047 = "\n" eq chr(21); + $is_ebcdic_37 = "\n" eq chr(37); + $is_ebcdic_1047 = "\n" eq chr(21); Or better still choose a character that is uniquely encoded in any of the code sets, e.g.: - my $is_ascii = ord('[') == 91; - my $is_ebcdic_37 = ord('[') == 186; - my $is_ebcdic_1047 = ord('[') == 173; - my $is_ebcdic_POSIX_BC = ord('[') == 187; + $is_ascii = ord('[') == 91; + $is_ebcdic_37 = ord('[') == 186; + $is_ebcdic_1047 = ord('[') == 173; + $is_ebcdic_POSIX_BC = ord('[') == 187; However, it would be unwise to write tests such as: - my $is_ascii = "\r" ne chr(13); # WRONG - my $is_ascii = "\n" ne chr(10); # ILL ADVISED + $is_ascii = "\r" ne chr(13); # WRONG + $is_ascii = "\n" ne chr(10); # ILL ADVISED Obviously the first of these will fail to distinguish most ASCII machines -from either a CCSID 0037, a 1047, or a POSIX-BC EBCDIC machine since "\r" eq -chr(13) under all of those coded character sets. But note too that -because "\n" is chr(13) and "\r" is chr(10) on the MacIntosh (which is an +from either a CCSID 0037, a 1047, or a POSIX-BC EBCDIC machine since "\r" eq +chr(13) under all of those coded character sets. But note too that +because "\n" is chr(13) and "\r" is chr(10) on the MacIntosh (which is an ASCII machine) the second C<$is_ascii> test will lead to trouble there. -To determine whether or not perl was built under an EBCDIC +To determine whether or not perl was built under an EBCDIC code page you can use the Config module like so: use Config; - my $is_ebcdic = $Config{'ebcdic'} eq 'define'; + $is_ebcdic = $Config{'ebcdic'} eq 'define'; =head1 CONVERSIONS @@ -638,30 +556,29 @@ The data in the table are in ASCII order hence the EBCDIC columns provide easy to use ASCII to EBCDIC operations that are also easily reversed. -For example, to convert ASCII to code page 037 take the output of the second -column from the output of recipe 0 (modified to add \\ characters) and use +For example, to convert ASCII to code page 037 take the output of the second +column from the output of recipe 0 (modified to add \\ characters) and use it in tr/// like so: - my $cp_037 = join '', - qq[\000\001\002\003\234\011\206\177\227\215\216\013\014\015\016\017], - qq[\020\021\022\023\235\205\010\207\030\031\222\217\034\035\036\037], - qq[\200\201\202\203\204\012\027\033\210\211\212\213\214\005\006\007], - qq[\220\221\026\223\224\225\226\004\230\231\232\233\024\025\236\032], - qq[\040\240\342\344\340\341\343\345\347\361\242\056\074\050\053\174], - qq[\046\351\352\353\350\355\356\357\354\337\041\044\052\051\073\254], - qq[\055\057\302\304\300\301\303\305\307\321\246\054\045\137\076\077], - qq[\370\311\312\313\310\315\316\317\314\140\072\043\100\047\075\042], - qq[\330\141\142\143\144\145\146\147\150\151\253\273\360\375\376\261], - qq[\260\152\153\154\155\156\157\160\161\162\252\272\346\270\306\244], - qq[\265\176\163\164\165\166\167\170\171\172\241\277\320\335\336\256], - qq[\136\243\245\267\251\247\266\274\275\276\133\135\257\250\264\327], - qq[\173\101\102\103\104\105\106\107\110\111\255\364\366\362\363\365], - qq[\175\112\113\114\115\116\117\120\121\122\271\373\374\371\372\377], - qq[\134\367\123\124\125\126\127\130\131\132\262\324\326\322\323\325], - qq[\060\061\062\063\064\065\066\067\070\071\263\333\334\331\332\237]; + $cp_037 = + '\000\001\002\003\234\011\206\177\227\215\216\013\014\015\016\017' . + '\020\021\022\023\235\205\010\207\030\031\222\217\034\035\036\037' . + '\200\201\202\203\204\012\027\033\210\211\212\213\214\005\006\007' . + '\220\221\026\223\224\225\226\004\230\231\232\233\024\025\236\032' . + '\040\240\342\344\340\341\343\345\347\361\242\056\074\050\053\174' . + '\046\351\352\353\350\355\356\357\354\337\041\044\052\051\073\254' . + '\055\057\302\304\300\301\303\305\307\321\246\054\045\137\076\077' . + '\370\311\312\313\310\315\316\317\314\140\072\043\100\047\075\042' . + '\330\141\142\143\144\145\146\147\150\151\253\273\360\375\376\261' . + '\260\152\153\154\155\156\157\160\161\162\252\272\346\270\306\244' . + '\265\176\163\164\165\166\167\170\171\172\241\277\320\335\336\256' . + '\136\243\245\267\251\247\266\274\275\276\133\135\257\250\264\327' . + '\173\101\102\103\104\105\106\107\110\111\255\364\366\362\363\365' . + '\175\112\113\114\115\116\117\120\121\122\271\373\374\371\372\377' . + '\134\367\123\124\125\126\127\130\131\132\262\324\326\322\323\325' . + '\060\061\062\063\064\065\066\067\070\071\263\333\334\331\332\237' ; my $ebcdic_string = $ascii_string; - eval '$ebcdic_string =~ tr/\000-\377/' . $cp_037 . '/'; To convert from EBCDIC 037 to ASCII just reverse the order of the tr/// @@ -684,12 +601,12 @@ On OS/390 or z/OS see the iconv(1) manpage. One way to invoke the iconv shell utility from within perl would be to: # OS/390 or z/OS example - my $ascii_data = `echo '$ebcdic_data'| iconv -f IBM-1047 -t ISO8859-1` + $ascii_data = `echo '$ebcdic_data'| iconv -f IBM-1047 -t ISO8859-1` or the inverse map: # OS/390 or z/OS example - my $ebcdic_data = `echo '$ascii_data'| iconv -f ISO8859-1 -t IBM-1047` + $ebcdic_data = `echo '$ascii_data'| iconv -f ISO8859-1 -t IBM-1047` For other perl based conversion options see the Convert::* modules on CPAN. @@ -704,7 +621,7 @@ care on EBCDIC machines. For example the following array will have twenty six elements on either an EBCDIC machine or an ASCII machine: - my @alphabet = ( 'A'..'Z' ); # $#alphabet == 25 + @alphabet = ('A'..'Z'); # $#alphabet == 25 The bitwise operators such as & ^ | may return different results when operating on string or character data in a perl program running @@ -712,10 +629,10 @@ on an EBCDIC machine than when run on an ASCII machine. Here is an example adapted from the one in L: # EBCDIC-based examples - print "j p \n" ^ " a h"; # prints "JAPH\n" - print "JA" | " ph\n"; # prints "japh\n" - print "JAPH\nJunk" & "\277\277\277\277\277"; # prints "japh\n" - print 'p N$' ^ " E C character that will remain at @@ -1072,7 +989,7 @@ may also be expressed as either of: where 7E is the hexadecimal ASCII code point for '~'. Here is an example of decoding such a URL under CCSID 1047: - my $url = 'http://www.pvhp.com/%7Epvhp/'; + $url = 'http://www.pvhp.com/%7Epvhp/'; # this array assumes code page 1047 my @a2e_1047 = ( 0, 1, 2, 3, 55, 45, 46, 47, 22, 5, 21, 11, 12, 13, 14, 15, @@ -1097,7 +1014,7 @@ of decoding such a URL under CCSID 1047: Conversely, here is a partial solution for the task of encoding such a URL under the 1047 code page: - my $url = 'http://www.pvhp.com/~pvhp/'; + $url = 'http://www.pvhp.com/~pvhp/'; # this array assumes code page 1047 my @e2a_1047 = ( 0, 1, 2, 3,156, 9,134,127,151,141,142, 11, 12, 13, 14, 15, @@ -1117,7 +1034,7 @@ a URL under the 1047 code page: 92,247, 83, 84, 85, 86, 87, 88, 89, 90,178,212,214,210,211,213, 48, 49, 50, 51, 52, 53, 54, 55, 56, 57,179,219,220,217,218,159 ); - # The following regular expression does not address the + # The following regular expression does not address the # mappings for: ('.' => '%2E', '/' => '%2F', ':' => '%3A') $url =~ s/([\t "#%&\(\),;<=>\?\@\[\\\]^`{|}~])/sprintf("%%%02X",$e2a_1047[ord($1)])/ge; @@ -1134,13 +1051,10 @@ The C template to pack() or unpack() will render EBCDIC data in EBCDIC characters equivalent to their ASCII counterparts. For example, the following will print "Yes indeed\n" on either an ASCII or EBCDIC computer: - my $all_byte_chrs = ''; - - $all_byte_chrs .= chr($_) foreach 0 .. 255; - - my $uuencode_byte_chrs = pack('u', $all_byte_chrs); - - (my $uu = <<' ENDOFHEREDOC') =~ s/^\s*//gm; + $all_byte_chrs = ''; + for (0..255) { $all_byte_chrs .= chr($_); } + $uuencode_byte_chrs = pack('u', $all_byte_chrs); + ($uu = <<'ENDOFHEREDOC') =~ s/^\s*//gm; M``$"`P0%!@<("0H+#`T.#Q`1$A,4%187&!D:&QP='A\@(2(C)"4F)R@I*BLL M+2XO,#$R,S0U-C'EZ>WQ]?G^`@8*#A(6& @@ -1148,22 +1062,21 @@ following will print "Yes indeed\n" on either an ASCII or EBCDIC computer: MM+6VM[BYNKN\O;Z_P,'"P\3%QL?(R+CY.7FY^CIZNOL[>[O\/'R\_3U]O?X^?K[_/W^_P`` ENDOFHEREDOC - if ( $uuencode_byte_chrs eq $uu ) { + if ($uuencode_byte_chrs eq $uu) { print "Yes "; } $uudecode_byte_chrs = unpack('u', $uuencode_byte_chrs); - if ( $uudecode_byte_chrs eq $all_byte_chrs ) { + if ($uudecode_byte_chrs eq $all_byte_chrs) { print "indeed\n"; } Here is a very spartan uudecoder that will work on EBCDIC provided that the @e2a array is filled in appropriately: - #!/usr/bin/perl - my @e2a = ( - # this must be filled in - ); - $_ = <> until my($mode,$file) = /^begin\s*(\d*)\s*(\S*)/; + #!/usr/local/bin/perl + @e2a = ( # this must be filled in + ); + $_ = <> until ($mode,$file) = /^begin\s*(\d*)\s*(\S*)/; open(OUT, "> $file") if $file ne ""; while(<>) { last if /^end/; @@ -1182,7 +1095,7 @@ On ASCII encoded machines it is possible to strip characters outside of the printable set using: # This QP encoder works on ASCII only - my $qp_string =~ s/([=\x00-\x1F\x80-\xFF])/sprintf("=%02X",ord($1))/ge; + $qp_string =~ s/([=\x00-\x1F\x80-\xFF])/sprintf("=%02X",ord($1))/ge; Whereas a QP encoder that works on both ASCII and EBCDIC machines would look somewhat like the following (where the EBCDIC branch @e2a @@ -1191,14 +1104,12 @@ array is omitted for brevity): if (ord('A') == 65) { # ASCII $delete = "\x7F"; # ASCII @e2a = (0 .. 255) # ASCII to ASCII identity map - - } else { # EBCDIC + } + else { # EBCDIC $delete = "\x07"; # EBCDIC - @e2a = ( - # EBCDIC to ASCII map (as shown above) - ); + @e2a = # EBCDIC to ASCII map (as shown above) } - my $qp_string =~ + $qp_string =~ s/([^ !"\#\$%&'()*+,\-.\/0-9:;<>?\@A-Z[\\\]^_`a-z{|}~$delete])/sprintf("=%02X",$e2a[ord($1)])/ge; (although in production code the substitutions might be done @@ -1233,14 +1144,14 @@ work on ASCII and EBCDIC machines: #!/usr/local/bin/perl - while ( <> ) { + while(<>){ tr/n-za-mN-ZA-M/a-zA-Z/; print; } In one-liner form: - perl -pe 'tr/n-za-mN-ZA-M/a-zA-Z/' + perl -ne 'tr/n-za-mN-ZA-M/a-zA-Z/;print' =head1 Hashing order and checksums @@ -1386,3 +1297,5 @@ Thanks also to Vickie Cooper, Philip Newton, William Raffloer, and Joe Smith. Trademarks, registered trademarks, service marks and registered service marks used in this document are the property of their respective owners. + +