ext/Encode/bin/unidump

   1 #!./perl
   2
   3 use strict;
   4 use Encode;
   5 use Getopt::Std;
   6 my %Opt; getopts("ChH:e:f:t:s:pPv", \%Opt);
   7 $Opt{p} ||= $Opt{P};
   8 $Opt{e} ||= 'utf8';
   9 $Opt{f} ||= $Opt{e};
  10 $Opt{t} ||= $Opt{e};
  11 $Opt{h} and help();
  12
  13 my ($linebuf, $outbuf);
  14 my $CPL = $Opt{p} ? 64 : 8;
  15 my $linenum;
  16 my $linesperheading = $Opt{H};
  17 my $nchars;
  18 our $PrevChunk;
  19
  20 $Opt{h} and help();
  21 $Opt{p} and do_perl($Opt{s});
  22 do_dump($Opt{s});
  23 exit;
  24
  25 #
  26
  27 sub do_perl{
  28     my $string = shift;
  29     $Opt{P} and print "#!$^X -w\nprint\n";
  30     unless ($string){
  31         while(<>){
  32             use utf8;
  33             $linebuf .=  Encode::decode($Opt{f}, $_);
  34             while($linebuf){
  35                 my $chr =  render_p(substr($linebuf, 0, 1));
  36                 substr($linebuf, 0, 1) = '';
  37                 length($outbuf) + length($chr) > $CPL and print_P();
  38                 $outbuf .= $chr;
  39             }
  40         }
  41         $outbuf and print print_P(";");
  42     }else{
  43         while($string){
  44             my $chr =  render_p(substr($string, 0, 1));
  45             substr($string, 0, 1) = '';
  46             length($outbuf) + length($chr) > $CPL and print_P();
  47             $outbuf .= $chr;
  48         }
  49     }
  50     $outbuf and print print_P(";");
  51     exit;
  52 }
  53
  54 sub render_p{
  55     my ($chr, $format) = @_;
  56     our %S2pstr;
  57     $S2pstr{$chr} and return $S2pstr{$chr}; # \t\n...
  58     $chr =~ /[\x20-\x7e]/ and return $chr;  # ascii, printable;
  59     my $fmt = ($chr =~ /[\x00-\x1f\x7F]/)  ?
  60         q(\x%x) : q(\x{%x});
  61     return sprintf $fmt, ord($chr);
  62 }
  63
  64 sub print_P{
  65     my $end = shift;
  66     $outbuf or return;
  67     print '"', encode($Opt{t}, $outbuf), '"';
  68     my $tail = $Opt{P} ? $end ? "$end" :  "," : '';
  69     print $tail, "\n";
  70     $outbuf = '';
  71 }
  72
  73 sub do_dump{
  74     my $string = shift;
  75     !$Opt{p} and exists $Opt{H} and print_H();
  76     unless ($string){
  77         while(<>){
  78             use utf8;
  79             $linebuf .=  Encode::decode($Opt{f}, $_);
  80             while (length($linebuf) > $CPL){
  81                 my $chunk = substr($linebuf, 0, $CPL);
  82                 print_C($chunk, $linenum++);
  83                 substr($linebuf, 0, $CPL) = '';
  84                 $Opt{H} and $linenum % $Opt{H} == $CPL-1 and print_S();
  85             }
  86         }
  87         $linebuf and print_C($linebuf);
  88     }else{
  89         while ($string){
  90             my $chunk = substr($string, 0, $CPL);
  91             print_C($chunk, $linenum++);
  92             substr($string,0, $CPL) = '';
  93             $Opt{H} and $linenum % $Opt{H} == $CPL-1 and print_S();
  94         }
  95     }
  96     exit;
  97 }
  98
  99 sub print_S{
 100     print "--------+------------------------------------------------";
 101     if ($Opt{C}){
 102         print "-+-----------------";
 103     }
 104     print "\n";
 105 }
 106 sub print_H{
 107     print "  Offset      0     1     2     3     4     5     6     7";
 108     if ($Opt{C}){
 109         print " |  0 1 2 3 4 5 6 7";
 110     }
 111     print "\n";
 112     print_S;
 113 }
 114
 115 sub print_C{
 116     my ($chunk, $linenum) = @_;
 117     if (!$Opt{v} and $chunk eq $PrevChunk){
 118         printf "%08x *\n", $linenum*8; return;
 119     }
 120     $PrevChunk = $chunk;
 121     my $end = length($chunk) - 1;
 122     my (@ord, @chr);
 123     for my $i (0..$end){
 124         use utf8;
 125         my $chr = substr($chunk,$i,1);
 126         my $ord = ord($chr);
 127         my $fmt = $ord <= 0xffff ? "  %04x" : " %05x";
 128         push @ord, (sprintf $fmt, $ord);
 129         $Opt{C} and push @chr, render_c($chr);
 130     }
 131     if (++$end < 7){
 132         for my $i ($end..7){
 133             push @ord, (" " x 6);
 134         }
 135     }
 136     my $line = sprintf "%08x %s", $linenum*8, join('', @ord);
 137     $Opt{C} and $line .= sprintf " | %s",  join('', @chr);
 138     print encode($Opt{t}, $line), "\n";
 139 }
 140
 141 sub render_c{
 142     my ($chr, $format) = @_;
 143     our (%S2str, $IsFullWidth);
 144     $chr =~ /[\p{IsControl}\s]/o and return $S2str{$chr} || "  ";
 145     $chr =~ $IsFullWidth and return $chr; # as is
 146     return " " . $chr;
 147 }
 148
 149 sub help{
 150     my $message = shift;
 151     use File::Basename;
 152     my $name = basename($0);
 153     $message and print STDERR "$name error: $message\n";
 154     print STDERR <<"EOT";
 155 Usage:
 156   $name -[options...] [files...]
 157   $name -[options...] -s "string"
 158   $name -h
 159   -h prints this message.
 160 Inherited from hexdump;
 161   -C Canonical unidump mode
 162   -v prints the duplicate line as is.  Without this option,
 163      single "*" will be printed instead.
 164 For unidump only
 165   -p prints in perl literals that you can copy and paste directly
 166      to your perl script.
 167   -P prints in perl executable format!
 168   -u prints a bunch of "Uxxxx,".  Handy when you want to pass your
 169      characters in mailing lists.
 170 IO Options:
 171   -e io_encoding    same as "-f io_encoding -t io_encoding"
 172   -f from_encoding  convert the source stream from this encoding
 173   -t to_encoding    print to STDOUT in this encoding
 174   -s string         "string" will be converted instead of STDIN.
 175   -H nline          prints separater for each nlines of output.
 176                     0 means only the table headding be printed.
 177 EOT
 178   exit;
 179 }
 180
 181 BEGIN{
 182     our %S2pstr= (
 183                   "\\" => '\\\\',
 184                   "\0" => '\0',
 185                   "\t" => '\t',
 186                   "\n" => '\n',
 187                   "\r" => '\r',
 188                   "\v" => '\v',
 189                   "\a" => '\a',
 190                   "\e" => '\e',
 191                   "\"" => qq(\\\"),
 192                   "\'" => qq(\\\'),
 193                   '$'  => '\$',
 194                   "@"  => '\@',
 195                   "%"  => '\%',
 196                  );
 197
 198     our %S2str = (
 199                   qq(\x00) => q(\0),  # NULL
 200                   qq(\x01) => q(^A),  # START OF HEADING
 201                   qq(\x02) => q(^B),  # START OF TEXT
 202                   qq(\x03) => q(^C),  # END OF TEXT
 203                   qq(\x04) => q(^D),  # END OF TRANSMISSION
 204                   qq(\x05) => q(^E),  # ENQUIRY
 205                   qq(\x06) => q(^F),  # ACKNOWLEDGE
 206                   qq(\x07) => q(\a),  # BELL
 207                   qq(\x08) => q(^H),  # BACKSPACE
 208                   qq(\x09) => q(\t),  # HORIZONTAL TABULATION
 209                   qq(\x0A) => q(\n),  # LINE FEED
 210                   qq(\x0B) => q(\v),  # VERTICAL TABULATION
 211                   qq(\x0C) => q(^L),  # FORM FEED
 212                   qq(\x0D) => q(\r),  # CARRIAGE RETURN
 213                   qq(\x0E) => q(^N),  # SHIFT OUT
 214                   qq(\x0F) => q(^O),  # SHIFT IN
 215                   qq(\x10) => q(^P),  # DATA LINK ESCAPE
 216                   qq(\x11) => q(^Q),  # DEVICE CONTROL ONE
 217                   qq(\x12) => q(^R),  # DEVICE CONTROL TWO
 218                   qq(\x13) => q(^S),  # DEVICE CONTROL THREE
 219                   qq(\x14) => q(^T),  # DEVICE CONTROL FOUR
 220                   qq(\x15) => q(^U),  # NEGATIVE ACKNOWLEDGE
 221                   qq(\x16) => q(^V),  # SYNCHRONOUS IDLE
 222                   qq(\x17) => q(^W),  # END OF TRANSMISSION BLOCK
 223                   qq(\x18) => q(^X),  # CANCEL
 224                   qq(\x19) => q(^Y),  # END OF MEDIUM
 225                   qq(\x1A) => q(^Z),  # SUBSTITUTE
 226                   qq(\x1B) => q(\e),  # ESCAPE (\c[)
 227                   qq(\x1C) => "^\\",  # FILE SEPARATOR
 228                   qq(\x1D) => "^\]",  # GROUP SEPARATOR
 229                   qq(\x1E) => q(^^),  # RECORD SEPARATOR
 230                   qq(\x1F) => q(^_),  # UNIT SEPARATOR
 231                   );
 232     #
 233     # Generated out of lib/unicore/EastAsianWidth.txt
 234     # will it work ?
 235     #
 236     our $IsFullWidth =
 237         qr/^[
 238              \x{1100}-\x{1159}
 239              \x{115F}-\x{115F}
 240              \x{2329}-\x{232A}
 241              \x{2E80}-\x{2E99}
 242              \x{2E9B}-\x{2EF3}
 243              \x{2F00}-\x{2FD5}
 244              \x{2FF0}-\x{2FFB}
 245              \x{3000}-\x{303E}
 246              \x{3041}-\x{3096}
 247              \x{3099}-\x{30FF}
 248              \x{3105}-\x{312C}
 249              \x{3131}-\x{318E}
 250              \x{3190}-\x{31B7}
 251              \x{31F0}-\x{321C}
 252              \x{3220}-\x{3243}
 253              \x{3251}-\x{327B}
 254              \x{327F}-\x{32CB}
 255              \x{32D0}-\x{32FE}
 256              \x{3300}-\x{3376}
 257              \x{337B}-\x{33DD}
 258              \x{3400}-\x{4DB5}
 259              \x{4E00}-\x{9FA5}
 260              \x{33E0}-\x{33FE}
 261              \x{A000}-\x{A48C}
 262              \x{AC00}-\x{D7A3}
 263              \x{A490}-\x{A4C6}
 264              \x{F900}-\x{FA2D}
 265              \x{FA30}-\x{FA6A}
 266              \x{FE30}-\x{FE46}
 267              \x{FE49}-\x{FE52}
 268              \x{FE54}-\x{FE66}
 269              \x{FE68}-\x{FE6B}
 270              \x{FF01}-\x{FF60}
 271              \x{FFE0}-\x{FFE6}
 272              \x{20000}-\x{2A6D6}
 273          ]$/xo;
 274 }
 275
 276 __END__