#!./perl use strict; use Encode; use Getopt::Std; my %Opt; getopts("ChH:e:f:t:s:pPv", \%Opt); $Opt{p} ||= $Opt{P}; $Opt{e} ||= 'utf8'; $Opt{f} ||= $Opt{e}; $Opt{t} ||= $Opt{e}; $Opt{h} and help(); my ($linebuf, $outbuf); my $CPL = $Opt{p} ? 64 : 8; my $linenum; my $linesperheading = $Opt{H}; my $nchars; our $PrevChunk; $Opt{h} and help(); $Opt{p} and do_perl($Opt{s}); do_dump($Opt{s}); exit; # sub do_perl{ my $string = shift; $Opt{P} and print "#!$^X -w\nprint\n"; unless ($string){ while(){ use utf8; $linebuf .= Encode::decode($Opt{f}, $_); while($linebuf){ my $chr = render_p(substr($linebuf, 0, 1, '')); length($outbuf) + length($chr) > $CPL and print_P(); $outbuf .= $chr; } } $outbuf and print print_P(";"); }else{ while($string){ my $chr = render_p(substr($string, 0, 1, '')); length($outbuf) + length($chr) > $CPL and print_P(); $outbuf .= $chr; } } $outbuf and print print_P(";"); exit; } sub render_p{ my ($chr, $format) = @_; our %S2pstr; $S2pstr{$chr} and return $S2pstr{$chr}; # \t\n... $chr =~ /[\x20-\x7e]/ and return $chr; # ascii, printable; my $fmt = ($chr =~ /[\x00-\x1f\x7F]/) ? q(\x%x) : q(\x{%x}); return sprintf $fmt, ord($chr); } sub print_P{ my $end = shift; $outbuf or return; print '"', encode($Opt{t}, $outbuf), '"'; my $tail = $Opt{P} ? $end ? "$end" : "," : ''; print $tail, "\n"; $outbuf = ''; } sub do_dump{ my $string = shift; !$Opt{p} and exists $Opt{H} and print_H(); unless ($string){ while(){ use utf8; $linebuf .= Encode::decode($Opt{f}, $_); while (length($linebuf) > $CPL){ my $chunk = substr($linebuf, 0, $CPL, ''); print_C($chunk, $linenum++); $Opt{H} and $linenum % $Opt{H} == $CPL-1 and print_S(); } } $linebuf and print_C($linebuf); }else{ while ($string){ my $chunk = substr($string, 0, $CPL, ''); print_C($chunk, $linenum++); $Opt{H} and $linenum % $Opt{H} == $CPL-1 and print_S(); } } exit; } sub print_S{ print "--------+------------------------------------------------"; if ($Opt{C}){ print "-+-----------------"; } print "\n"; } sub print_H{ print " Offset 0 1 2 3 4 5 6 7"; if ($Opt{C}){ print " | 0 1 2 3 4 5 6 7"; } print "\n"; print_S; } sub print_C{ my ($chunk, $linenum) = @_; if (!$Opt{v} and $chunk eq $PrevChunk){ printf "%08x *\n", $linenum*8; return; } $PrevChunk = $chunk; my $end = length($chunk) - 1; my (@ord, @chr); for my $i (0..$end){ use utf8; my $chr = substr($chunk,$i,1); my $ord = ord($chr); my $fmt = $ord push @ord, (sprintf $fmt, $ord); $Opt{C} and push @chr, render_c($chr); } if (++$end < 7){ for my $i ($end..7){ push @ord, (" " x 6); } } my $line = sprintf "%08x %s", $linenum*8, join('', @ord); $Opt{C} and $line .= sprintf " | %s", join('', @chr); print encode($Opt{t}, $line), "\n"; } sub render_c{ my ($chr, $format) = @_; our (%S2str, $IsFullWidth); $chr =~ /[\p{IsControl}\s]/o and return $S2str{$chr} || " "; $chr =~ $IsFullWidth and return $chr; # as is return " " . $chr; } sub help{ my $message = shift; use File::Basename; my $name = basename($0); $message and print STDERR "$name error: $message\n"; print STDERR Usage: $name -[options...] [files...] $name -[options...] -s "string" $name -h -h prints this message. Inherited from hexdump; -C Canonical unidump mode -v prints the duplicate line as is. Without this option, single "*" will be printed instead. For unidump only -p prints in perl literals that you can copy and paste directly to your perl script. -P prints in perl executable format! -u prints a bunch of "Uxxxx,". Handy when you want to pass your characters in mailing lists. IO Options: -e io_encoding same as "-f io_encoding -t io_encoding" -f from_encoding convert the source stream from this encoding -t to_encoding print to STDOUT in this encoding -s string "string" will be converted instead of STDIN. -H nline prints separater for each nlines of output. 0 means only the table headding be printed. EOT exit; } BEGIN{ our %S2pstr= ( "\\" => '\\\\', "\0" => '\0', "\t" => '\t', "\n" => '\n', "\r" => '\r', "\v" => '\v', "\a" => '\a', "\e" => '\e', "\"" => qq(\\\"), "\'" => qq(\\\'), '$' => '\$', "@" => '\@', "%" => '\%', ); our %S2str = ( qq(\x00) => q(\0), # NULL qq(\x01) => q(^A), # START OF HEADING qq(\x02) => q(^B), # START OF TEXT qq(\x03) => q(^C), # END OF TEXT qq(\x04) => q(^D), # END OF TRANSMISSION qq(\x05) => q(^E), # ENQUIRY qq(\x06) => q(^F), # ACKNOWLEDGE qq(\x07) => q(\a), # BELL qq(\x08) => q(^H), # BACKSPACE qq(\x09) => q(\t), # HORIZONTAL TABULATION qq(\x0A) => q(\n), # LINE FEED qq(\x0B) => q(\v), # VERTICAL TABULATION qq(\x0C) => q(^L), # FORM FEED qq(\x0D) => q(\r), # CARRIAGE RETURN qq(\x0E) => q(^N), # SHIFT OUT qq(\x0F) => q(^O), # SHIFT IN qq(\x10) => q(^P), # DATA LINK ESCAPE qq(\x11) => q(^Q), # DEVICE CONTROL ONE qq(\x12) => q(^R), # DEVICE CONTROL TWO qq(\x13) => q(^S), # DEVICE CONTROL THREE qq(\x14) => q(^T), # DEVICE CONTROL FOUR qq(\x15) => q(^U), # NEGATIVE ACKNOWLEDGE qq(\x16) => q(^V), # SYNCHRONOUS IDLE qq(\x17) => q(^W), # END OF TRANSMISSION BLOCK qq(\x18) => q(^X), # CANCEL qq(\x19) => q(^Y), # END OF MEDIUM qq(\x1A) => q(^Z), # SUBSTITUTE qq(\x1B) => q(\e), # ESCAPE (\c[) qq(\x1C) => "^\\", # FILE SEPARATOR qq(\x1D) => "^\]", # GROUP SEPARATOR qq(\x1E) => q(^^), # RECORD SEPARATOR qq(\x1F) => q(^_), # UNIT SEPARATOR ); # # Generated out of lib/unicore/EastAsianWidth.txt # will it work ? # our $IsFullWidth = qr/^[ \x{1100}-\x{1159} \x{115F}-\x{115F} \x{2329}-\x{232A} \x{2E80}-\x{2E99} \x{2E9B}-\x{2EF3} \x{2F00}-\x{2FD5} \x{2FF0}-\x{2FFB} \x{3000}-\x{303E} \x{3041}-\x{3096} \x{3099}-\x{30FF} \x{3105}-\x{312C} \x{3131}-\x{318E} \x{3190}-\x{31B7} \x{31F0}-\x{321C} \x{3220}-\x{3243} \x{3251}-\x{327B} \x{327F}-\x{32CB} \x{32D0}-\x{32FE} \x{3300}-\x{3376} \x{337B}-\x{33DD} \x{3400}-\x{4DB5} \x{4E00}-\x{9FA5} \x{33E0}-\x{33FE} \x{A000}-\x{A48C} \x{AC00}-\x{D7A3} \x{A490}-\x{A4C6} \x{F900}-\x{FA2D} \x{FA30}-\x{FA6A} \x{FE30}-\x{FE46} \x{FE49}-\x{FE52} \x{FE54}-\x{FE66} \x{FE68}-\x{FE6B} \x{FF01}-\x{FF60} \x{FFE0}-\x{FFE6} \x{20000}-\x{2A6D6} ]$/xo; } __END__
