user-tools/unicodestyle

   1 #!/usr/bin/env perl
   2
   3 use utf8;
   4 use Getopt::Long;
   5 use Data::Dumper;
   6 use Encode qw/decode encode/;
   7 use constant { LOWER => 0, UPPER => 1, COMMON_SURROGATE => 0xd835, };
   8 no if ($] >= 5.018), 'warnings' => 'experimental::smartmatch';
   9 binmode STDIN, ':utf8';
  10 binmode STDOUT, ':utf8';
  11
  12 $msg_not_support_combine = "Combining styles %s and %s is not supported.\n";
  13
  14
  15 %Transformer = (
  16         double => [0xdcf1, 0xdcf7],
  17         script => [0xdc89, 0xdc8f],
  18         code => [0xde29, 0xde2f],
  19         fraktur => [0xdcbd, 0xdcc3],
  20         bold => [0xdd8d, 0xdd93],
  21         italic => [0xddc1, 0xddc7],
  22         bold_italic => [0xddf5, 0xddfb],
  23         smallcaps => {
  24                 ignorecase => 1,
  25                 transtable => {qw/
  26                         B 0x299 G 0x262 H 0x29C I 0x26A L 0x29F N 0x274 R 0x280 Y 0x28F
  27                         0x276 0x276 0x153 0x276
  28                         A 0x1D00 C 0x1D04 D 0x1D05 E 0x1D07 J 0x1D0A K 0x1D0B M 0x1D0D O 0x1D0F P 0x1D18 T 0x1D1B U 0x1D1C V 0x1D20 W 0x1D21 Z 0x1D22
  29                         0xC6 0x1D01 0xE6 0x1D01
  30                         F 0xA730 S 0xA731
  31                         Q 0xA7AF
  32                 /},
  33         },
  34         circled => {
  35                 transrange => [
  36                         {input_start => 'A', input_end => 'Z', offset => 0x24B6},
  37                         {input_start => 'a', input_end => 'z', offset => 0x24D0},
  38                         {input_start => '1', input_end => '9', offset => 0x2460},
  39                         {input_start => '0', input_end => '0', offset => 0x24EA},
  40                 ],
  41         },
  42         circled_negative => {
  43                 transrange => [
  44                         {input_start => 'A', input_end => 'Z', offset => 0x1F150},
  45                         {input_start => '1', input_end => '9', offset => 0x2776},
  46                         {input_start => '0', input_end => '0', offset => 0x24FF},
  47                 ],
  48         },
  49         squared => {
  50                 transrange => [
  51                         {input_start => 'A', input_end => 'Z', offset => 0x1F130},
  52                 ],
  53         },
  54         negative_squared => {
  55                 transrange => [
  56                         {input_start => 'A', input_end => 'Z', offset => 0x1F170},
  57                 ],
  58         },
  59         parenthesized => {
  60                 transrange => [
  61                         {input_start => 'A', input_end => 'Z', offset => 0x1F110},
  62                         {input_start => 'a', input_end => 'z', offset => 0x249C},
  63                         {input_start => '1', input_end => '9', offset => 0x2474},
  64                 ],
  65         },
  66 );
  67
  68
  69 %Appender = (
  70         underline => ['̲', sub{ $_[0] !~ /[gjpqyQ,;_]/; }],
  71         strikethrough => ['̶', sub{1;}],
  72 );
  73
  74
  75 sub surrogate_pair
  76 {
  77         my $hi = shift;
  78         my $lo = shift;
  79         return 0x10000 + ($hi - 0xD800) * 0x400 + ($lo - 0xDC00);
  80 }
  81
  82 sub hexord
  83 {
  84         sprintf "0x%X", ord $_[0];
  85 }
  86
  87 sub uniqsort
  88 {
  89         my %h = map {$_=>1} @_;
  90         return sort keys %h;
  91 }
  92
  93 sub is_applicable_transformer
  94 {
  95         my ($chr, $trnkey) = @_;
  96         my $trn = $Transformer{$trnkey};
  97
  98         if(ref $trn eq 'ARRAY')
  99         {
 100                 return 1 if $chr =~ /[A-Za-z]/;
 101                 return '';
 102         }
 103         if(exists $trn->{transtable})
 104         {
 105                 return 1 if hexord($chr) ~~ [keys $trn->{transtable}];
 106                 return 1 if $chr ~~ [keys $trn->{transtable}];
 107                 return 1 if $trn->{ignorecase} and uc $chr ~~ [keys $trn->{transtable}];
 108         }
 109         if(exists $trn->{transrange})
 110         {
 111                 my $ord = ord $chr;
 112                 for my $r (@{$trn->{transrange}})
 113                 {
 114                         return 1 if $ord >= ord $r->{input_start} and $ord <= ord $r->{input_end}
 115                 }
 116         }
 117         return '';
 118 }
 119
 120 sub is_applicable
 121 {
 122         $_[0] =~ /[[:print:]]/;
 123 }
 124
 125
 126
 127
 128 $trans_style = undef;
 129 @appenders = ();
 130
 131
 132 for my $style (@ARGV)
 133 {
 134         if(exists $Appender{$style})
 135         {
 136                 push @appenders, $style;
 137                 next;
 138         }
 139
 140         if(defined $trans_style)
 141         {
 142                 my $combined = join '_', sort split(/_/, $trans_style), $style;
 143
 144                 if(exists $Transformer{$combined})
 145                 {
 146                         $trans_style = $combined;
 147                 }
 148                 else
 149                 {
 150                         die sprintf $msg_not_support_combine, $trans_style, $style;
 151                 }
 152         }
 153         else
 154         {
 155                 $trans_style = $style;
 156         }
 157 }
 158
 159 unless(exists $Transformer{$trans_style} or @appenders)
 160 {
 161         die "Unknown style or style can not be used alone: $trans_style\n".
 162             "Styles: ".(join ' ', uniqsort split /_/, join '_', keys %Transformer, keys %Appender)."\n";
 163 }
 164
 165
 166
 167 while(<STDIN>)
 168 {
 169         for my $char_in (split //)
 170         {
 171                 my $char_out = $char_in;
 172
 173                 if(is_applicable($char_in))
 174                 {
 175                         if(defined $trans_style and is_applicable_transformer($char_in, $trans_style))
 176                         {
 177                                 if(ref $Transformer{$trans_style} eq 'ARRAY')
 178                                 {
 179                                         my $case = $char_in =~ /[a-z]/ ? LOWER : UPPER;
 180                                         $char_out = chr surrogate_pair(COMMON_SURROGATE, $Transformer{$trans_style}->[$case] + ord $char_in);
 181                                 }
 182                                 else
 183                                 {
 184                                         if(exists $Transformer{$trans_style}->{transrange})
 185                                         {
 186                                                 for my $range (@{$Transformer{$trans_style}->{transrange}})
 187                                                 {
 188                                                         my ($char_in_ord, $input_start_ord, $input_end_ord) = map {ord $_} $char_in, $range->{input_start}, $range->{input_end};
 189                                                         if($char_in_ord >= $input_start_ord and $char_in_ord <= $input_end_ord)
 190                                                         {
 191                                                                 $char_out = chr($range->{offset} + ($char_in_ord - $input_start_ord));
 192                                                                 goto translated;
 193                                                         }
 194                                                 }
 195                                         }
 196                                         if(exists $Transformer{$trans_style}->{transtable})
 197                                         {
 198                                                 my @lookupchars = ($char_in, hexord($char_in));
 199                                                 push @lookupchars, uc $char_in, hexord(uc $char_in) if $Transformer{$trans_style}->{ignorecase};
 200                                                 for my $char_out_hex (map {$Transformer{$trans_style}->{transtable}->{$_}} @lookupchars)
 201                                                 {
 202                                                         if(defined $char_out_hex)
 203                                                         {
 204                                                                 $char_out = chr hex $char_out_hex;
 205                                                                 goto translated;
 206                                                         }
 207                                                 }
 208                                         }
 209                                         $char_out = $char_in;
 210                                         translated:
 211                                         1;
 212                                 }
 213                         }
 214                         for my $style (@appenders)
 215                         {
 216                                 if($Appender{$style}->[1]->($char_in))
 217                                 {
 218                                         $char_out .= $Appender{$style}->[0];
 219                                 }
 220                         }
 221                 }
 222
 223                 print $char_out;
 224         }
 225 }
 226
 227 __END__
 228
 229 =pod
 230
 231 =head1 NAME
 232
 233 unicodestyle - Add font styles to input text using Unicode
 234
 235 =cut
 236
 237
 238
 239 # TODO
 240 # remove style
 241 # detach diacritics
 242 # numbers
 243