view release on metacpan or  search on metacpan

scripts/digitdemog  view on Meta::CPAN

#!/usr/bin/perl
use 5.014 ; use strict ; use warnings ;  # the functions requires 5.10 for "state", 5.14 for srand. 
use Getopt::Std ; getopts '12$:=p:q:u:LS', \my%o ;  
use Math::Trig qw/pi/ ; # 5.4から
use Scalar::Util qw/looks_like_number/ ; # 5.7.3から
use Term::ANSIColor qw/:constants color/ ;  $Term::ANSIColor::AUTORESET = 1 ;
use Time::HiRes qw/sleep usleep gettimeofday tv_interval/ ; # 5.7.3から
use Encode ;

#$SIG{INT} = sub { & info ; exit 130 } ;
my $time0 = [ gettimeofday ] ;
my ${binFlag} = 1 if defined $o{u} && $o{u} eq '0' ;

$o{'$'} //= 'end' ;  # 文字の終端を表す記号
$o{p} //= '' ;  # 文字を切り分けるパターン。正規表現
binmode STDOUT, 'utf8' unless $binFlag ;

sub main () ; 
* main = $o{L} ? * bylen : $o{S} ? * blanks : * normal ; # <-- mainの定義はここである。
& main ; 
exit 0 ;

# どんな種類の空白かを数えるモード:
sub blanks ( ) { 
  my $header = <> if $o{'='} ; 
  my %seen ; # 同じ行が来たかどうかの判定に使う。数が集計される。
  my %counts ;

  while ( <> ) { 
    next if $o{1} && $seen{$_} ++ ; 
    chomp ; 
    $_ = decode_utf8 $_ unless $binFlag ; 
    my @blanks = m/[[:blank:]]/g ; # <-- -  perldoc  perlrecharclass　perlunicode を参照するのが良いかも Unicode文字プロパティ
    #print "XX" if @blanks ;
    $counts { $_ } ++ for @blanks ; 
  }

  for ( sort keys %counts ) { 
    print  sprintf "U+%X %s:\t%d\n", ord ($_) , $_ , $counts { $_ } ; 
  }
}

# 長さ毎に数えるモード:
sub bylen ( ) { 
	my $header = <> if $o{'='} ; 
	my %seen ; # 同じ行が来たかどうかの判定に使う。数が集計される。
	my %M ; # 文字列長さごとの文字列最小値と文字列最大値を格納する。
	my %frq ; # 文字列長ごとの頻度
	while ( <> ) {
		next if $o{1} && $seen{$_} ++ ;
		chomp ;
		$_ = decode_utf8 $_ unless $binFlag ;
		my $len = length $_ ; 
		$frq{$len} ++ ;
		$M{$len}[0] = $_ if ! defined $M{$len}[0] || $M{$len}[0] gt $_ ; 
		$M{$len}[1] = $_ if ! defined $M{$len}[1] || $M{$len}[1] lt $_ ; 		
		$M{$len}[2] = $_ if ! $o{2} && ! defined $M{$len}[2] ; 
		$M{$len}[3] = $_ if ! $o{2} ; 

	}

	print join ( "\t", map {UNDERLINE $_} qw[length freq min_str max_str] , ! $o{2} ? qw[first_str last_str ]:() ) , "\n" ;
	for ( sort { $a <=> $b } keys %M ) {  # 数値 (文字列の長さを表す)でソート 
    my @t = @{ $M{$_} } ;
    grep { defined $_ and $_ = qq['$_'] } @t unless defined $o{q} && $o{q} eq '0' ;