view release on metacpan or  search on metacpan

digitdemog  view on Meta::CPAN

#!/usr/bin/perl

# このプログラムの作成者 : 下野寿之 bin4tsv@gmail.com Toshiyuki Shimono

use 5.030 ; 
use warnings ; 
use Getopt::Std ;
use Getopt::Long qw [ GetOptions :config bundling no_ignore_case pass_through ] ; # GetOptionsFromArray ] ;
#Getopt::Long::Configure qw [ bundling ] ; #  1文字のオプションに対して有効。ずらずらつなげられる。
#Getopt::Long::Configure qw [ no_ignore_case ] ; # 大文字と小文字を区別する。
#Getopt::Long::Configure qw [ pass_through ] ; # 拾わなかった @ARGV の引数を残してくれるっぽい。posix_defaultの後で書くこと(!)。
use Term::ANSIColor qw/:constants color/ ;  $Term::ANSIColor::AUTORESET = 1 ;
use Time::HiRes qw/gettimeofday tv_interval/ ; # 5.7.3から
use List::Util qw[ max min first sum0 uniq ] ; 
use Encode qw [ decode_utf8 ] ;

GetOptions 'e=s' => \my@e , 'width=i' => \my$width ; # -e で指定されたパターンを何個でも拾う。
getopts '.:$:0:12:=b:g:n:o:q:u:w:y:L:R:S', \my%o ;  

$o{o} //= 0 ; # 桁の番号を0から始める ことがデフォルトだが、やはり1から始められるようにした。
my $dt_start = [ gettimeofday ] ;
my $optu0 = ($o{u}//'') eq 0 ; 
my $optq0 = ($o{q}//'') eq 0 ;
my $optw0 = ($o{w}//'') eq 0 ; 
my $oL2 = ($o{L}//'') eq 2 ; # $optL2 は長すぎるので、ちょっと特例的に短くしてみた
my $oL4 = ($o{L}//'') eq 4 ;

$o{'.'} //= 1 ;
$o{'$'} //= '$' ;  # 文字の終端を表す記号
binmode STDOUT, 'utf8' unless $optu0 ;

## 具体例を指示する -g についての処理
$o{g} //= 1 ; # 例として取り出すために、各頻度に対して何個異なる例を保持するか。
my $sep = do { my $c = $o{g} =~s/\d//gr ; $c = decode_utf8 $c if ! $optu0 ; $c ne '' ? $c : '|' } ; # 出力表での具体例の区切り文字。
$o{g} =~ s/\D//g ; 
$o{g} = 1 if $o{g} eq '' ;
my $header  ; # -1 が指定されたら読み飛ばしの対象となるが、一応保管。(2次情報として標準エラー出力に出す。)

## -y による頻度のフィルタリングをするための準備 : 
my @y_ranges = () ; # 出力される値の範囲が指定された場合の挙動を指定する。
# 次の2個の関数は、出力すべき値の範囲をフィルターの様に指定する。
& y_init () ;
sub y_init ( ) { 
  my @ranges = split /,/o , $o{y} // '' , -1 ; 
  grep { $_ = $_ . ".." . $_ unless m/\.\./ }  @ranges ; # = split /,/ , $o{y} // '' , -1 ; 
  do { m/^(\d*)\.\.(\d*)/ ; push @y_ranges , [ $1||1 , $2||'Inf' ] } for @ranges ; 
}
sub y_filter ( $ ) { 
  do { return not 0 if $_->[0] <= $_[0] && $_[0] <= $_->[1] } for @y_ranges ; 
  return @y_ranges ? not 1 : not 0 ; # 指定が無かった場合はとにかく真を返す。
}
  
## ここからメイン
sub main () ; 
* main = $oL2 || $oL4 ? * bylen : * main_normal ; # <-- mainの定義はここである。
& main ; 
exit 0 ;

###
END {
  exit if ($o{2}//'') eq 0 ;
  my $rl = d3 ($. // 0) ; # read lines
  my $procsec = tv_interval ${ dt_start } ;
  my $out = "$rl line(s) read; "; 
  $out .= do { chomp $header ; "\"$header\" is the 1st line; " } if defined $header ; 
  $out .= sprintf '%0.6f seconds (digitdemog)', $procsec ; # たまにマイクロ秒単位の$procsecが15桁くらいで表示されるのでsprintf。
  say STDERR BOLD DARK ITALIC CYAN $out ;
}

##
## 長さ毎に数えるモード :  (入力の具体的な値を見るため)
## 

sub bylen ( ) { 
  $header = <> if $o{'='} ; 
  my %freq ; # 同じ行が来たかどうかの判定に使う。数が集計される。
  my %M ; # 文字列長さごとの文字列最小値と文字列最大値を格納する。
  my %Lfrq ; # 文字列長ごとの頻度
  while ( <> ) {
    chomp ;
    s/\r$// unless $optw0 ;    
    $_ = decode_utf8 $_ unless $optu0 ;
    next if $freq{$_} ++ && $o{1} ; # && の前後の順序に注意
    my $len = length $_ ; 
    $Lfrq{$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 $_ ;     
    next unless $oL4 ; 
    $M{$len}[2] = $_ if ! defined $M{$len}[2] ; 
    $M{$len}[3] = $_ ;