[ViewVC] Annotation of: cvs/cvsroot/staticperl/perl/ext/Encode/bin/unidump

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