rfc1345convert

   1 #!/usr/bin/env perl
   2
   3 use strict;
   4 use warnings;
   5
   6 use Data::Dumper;
   7
   8 our $VERSION = '1.00';
   9
  10 if (0) {
  11         #TODO: automatic download if not specified on stdin
  12         require LWP::Simple;
  13         LWP::Simple::get('http://www.ietf.org/rfc/rfc1345.txt');
  14 }
  15
  16 # skip everything until a character indented by 1 space (table start)
  17 do {$_ = <>} until /^\s\S/;
  18
  19 my @t = $_;  # add first line (already read, assume it's ok)
  20
  21 # read the rest of the character table
  22 while ($_ = <>) {
  23         # check for table end (chapter 4)
  24         last if /^4/;
  25
  26         # parse table lines (ignore (unindented) page break)
  27         next unless s/^ //;
  28         chomp;
  29
  30         # add the line to @t
  31         if (s/^ {15}/ /) {
  32                 # continuation line (add to last entry)
  33                 $t[-1] .= $_;
  34         }
  35         else {
  36                 # add a new entry
  37                 push @t, $_;
  38         }
  39 }
  40
  41 # create a hash of desired input
  42 my %di;
  43 for (@t) {
  44         my ($mnem, $char, $name) = split / +/, $_, 3;
  45         next if length $mnem != 2;
  46         $di{$mnem} = hex $char;
  47 }
  48
  49 # XXX
  50 my %trans = (
  51         0xE001 => 0,  # join lines: not accepted
  52         0xE004 => 0,  # umlaut is no different from diaeresis 0x0308
  53         0xE005 => 0x0344, # discouraged
  54         0xE006 => 0x0300,
  55         0xE007 => 0x0301,
  56         0xE008 => 0x0302,
  57         0xE009 => 0x0303,
  58         0xE00A => 0x0304,
  59         0xE00B => 0x0306,
  60         0xE00C => 0x0307,
  61         0xE00D => 0x0308,
  62         0xE00E => 0x030A,
  63         0xE00F => 0x030B,
  64         0xE010 => 0x030C,
  65         0xE011 => 0x0327,
  66         0xE012 => 0x0328,
  67         0xE013 => 0x0332,
  68         0xE014 => 0x0333,
  69         0xE015 => 0x0338,
  70         0xE016 => 0x0345,
  71         0xE017 => 0x0314,
  72         0xE018 => 0x0313,
  73         0xE019 => 0x1FFE,
  74         0xE01A => 0x1FBF,
  75         0xE01B => 0x03D0,  # middle beta = curled beta?
  76         0xE01C => 0x25CB,
  77         0xE01D => 0x0192,
  78         0xE01E => 0x0292,
  79         0xE01F => 0x33C2,  # am, compatibility char
  80         0xE020 => 0x33D8,  # pm, compatibility char
  81         0xE021 => 0x2121,
  82         0xE022 => 0xFE8E,
  83         0xE023 => 0,  # dutch guilder 0192 is already encoded, and not very useful anyway
  84         0xE024 => 0x0393,
  85         0xE025 => 0x20D7,  # also 20D1; non-spacing
  86         0xE026 => 0x1FEF,
  87         0xE027 => 0x1FC0,
  88         0xE028 => 0x01F0, #but uppercase
  89 );
  90 for (values %di) {
  91         $_ >= 0xE000 or next;
  92         $_ = $trans{$_} if defined $trans{$_};
  93 }
  94
  95 # personal addendums
  96 my @extra;
  97 if (-r 'shiar.inc.txt') {
  98         open my $include, '<:utf8', 'shiar.inc.txt';
  99         for (readline $include) {
 100                 m{^([!"%'-Z_a-z]{2}) (.)} or next;
 101                 warn("$1 already defined"), next if defined $di{$1};
 102                 $di{$1} = ord $2;
 103                 push @extra, $1;
 104         }
 105 }
 106 warn $@ if $@;
 107
 108 # optionally get unicode character information
 109 my %info = eval {
 110         require Unicode::UCD;
 111         map {
 112                 $_ => Unicode::UCD::charinfo($di{$_})
 113                         || { block => '?', category => 'Xn', name => '', script => '' }
 114         } keys %di;
 115 };
 116
 117 # add custom categories for certain blocks
 118 for (values %info) {
 119         $_->{category} .= ' Xa' if $_->{block} eq 'Basic Latin';
 120         $_->{category} .= ' Xl' if $_->{block} eq 'Latin-1 Supplement';
 121 }
 122
 123 # mark unofficial extras as such
 124 $info{$_}->{category} .= ' Xz' for @extra;
 125
 126 for (keys %di) {
 127         $info{$_}->{string} = chr(9676) . chr($di{$_}) if $info{$_}->{combining};
 128         # find control characters (first 32 chars from 0 and 128)
 129         next unless ($di{$_} & ~0b1001_1111) == 0 or $di{$_} == 127;
 130         # rename to something more descriptive
 131         $info{$_}->{name} = $info{$_}->{unicode10}
 132                 ? '<'.$info{$_}->{unicode10}.'>'  # the old name was much more useful
 133                 : sprintf('<control U+%04X>', $di{$_});  # at least identify by value
 134         # show descriptive symbols instead of control chars themselves
 135         $info{$_}->{string} = $di{$_} < 32 ? chr($di{$_} + 0x2400) : chr(0xFFFD);
 136 }
 137
 138 # output perl code of hash
 139 # (assume no backslashes or curlies, so we can just q{} w/o escaping)
 140 print "+{\n";
 141 printf '(map {$_=>0} qw{%s}),'."\n", join(' ',
 142         map { substr($_, 1, 1).substr($_, 0, 1) } sort keys %di
 143 );
 144 printf "q{%s}=>[%s],\n", $_, join(',',
 145         $di{$_},   # original code point
 146         $info{$_}  # optional additional arguments
 147                 ? map {"'$_'"} @{ $info{$_} }{qw/name category script/},
 148                         $info{$_}->{string} || ()
 149                 : ()
 150 ) for sort keys %di;
 151 print "}\n";
 152