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 # personal addendums
  50 my @extra;
  51 if (-r 'shiar.inc.txt') {
  52         open my $include, '<:utf8', 'shiar.inc.txt';
  53         for (readline $include) {
  54                 m{^([!"%'-Z_a-z]{2}) (.)} or next;
  55                 warn("$1 already defined"), next if defined $di{$1};
  56                 $di{$1} = ord $2;
  57                 push @extra, $1;
  58         }
  59 }
  60 warn $@ if $@;
  61
  62 # optionally get unicode character information
  63 my %info = eval {
  64         require Unicode::UCD;
  65         map {
  66                 $_ => Unicode::UCD::charinfo($di{$_})
  67                         || { block => '?', category => 'Xn', name => '', script => '' }
  68         } keys %di;
  69 };
  70
  71 # add custom categories for certain blocks
  72 for (values %info) {
  73         $_->{category} .= ' Xa' if $_->{block} eq 'Basic Latin';
  74         $_->{category} .= ' Xl' if $_->{block} eq 'Latin-1 Supplement';
  75 }
  76
  77 # mark unofficial extras as such
  78 $info{$_}->{category} .= ' Xz' for @extra;
  79
  80 # output perl code of hash
  81 # (assume no backslashes or curlies, so we can just q{} w/o escaping)
  82 print "{\n";
  83 printf "q{%s}=>[%s],\n", $_, join(',',
  84         $di{$_},       # glyph code point
  85         $info{$_}  # optional additional arguments
  86                 ? map {"'$_'"} @{ $info{$_} }{qw/name category script/}
  87                 : ()
  88 ) for sort keys %di;
  89 print "}\n";
  90