| Commit | Line | Data |
|---|
| a999c27c |
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__ |
projects / p5sagit/p5-mst-13.2.git / blame