App-Bin4TSV

 view release on metacpan or  search on metacpan

scripts/backcolor  view on Meta::CPAN

while ( <> ) { 
	my @F = do { chomp ; split /\t/o, $_ , -1 } ; 
	for ( @F ) { 
		if ( looks_like_number ( $_ ) ) { 
			my $n = $o{s} ? sqrt ( $_ ) : $_ ;
			my $d = max 0, min 5, int $n / $o{d} ; 
			my $c = "on_rgb00$d" ;
			$_ = color ($c) . $_ . color ('reset') ; 
		}
	}
	say join "\t", @F ; 
}


=encoding utf8 

=head1

  $0
    TSVファイルにおいて、数値のセルに対して背景に色を付ける。

scripts/chars2code  view on Meta::CPAN

exit 0 ; 


# 1文字を制御文字についてはエスケープ文字を付けた様な形にする。ある種の文字の正規化する。
sub norChar($){
  state  $x = \{ 0,'\0',7,'\a',8,'\b',9,'\t',10,'\n',11,'\v',12,'\f',13,'\r',27,'\e'} ; 
  return $$x->{ ord $_[0] } // $_[0] ;
}

sub LinePreserve { 
  say CYAN UNDERLINE +( $o{':'} ? 'lin#:' : '' ) . '#char', DARK '(#bytes)' , RESET UNDERLINE "\tchar ", DARK "u+code .." ;
  while (<>) { 
  	my $str = decode ( $_ ) ; 
  	print CYAN 	+($o{':'}?($.+$base-1).":":''), length $str , DARK '('  , length $_ , ')' , RESET "\t" ;
    for ( split //, $str , 0 ) { 
      my @out = ( BOLD sprintf ( '%s' , norChar $_ ) , RESET DARK sprintf ( " $h%02x " , ord $_ ) ) ; 
      print @out ;
    }
    say '' ; 
  }
}

#  出力する各行は、入力の各文字に相当させている、動作
sub OneLineOneChar {
  my ($posC,$posL) = ($base) x2 ; #文字の先頭からの位置、 行番号
  * codify = $o{u} ? sub { sprintf 'u+%04x' , ord $_[0] } : sub { sprintf '0x%s', unpack 'H12', encode($_) } ; 
  for( ; <> ; $posL ++ ){
    my $posC0 = $posC ;
    for ( @_ = split //, decode($_), 0 ; defined($_=shift) ; $posC++ ) { 
      #my @out = ( sprintf ( "$h%04x" , ord encode($_) ) , sprintf ('[%s]' , norChar $_ ) ) ;
      #my @out = ( sprintf ( "$h%s" , (unpack 'h12' , encode($_) ) ) , sprintf ('[%s]' , norChar $_ ) ) ;
      my @out = ( &codify ($_) , sprintf ('[%s]' , norChar $_ ) ) ;  
      #unshift @out , sprintf ("$posC:$posL-$posCL(%s)", encode($_) )  if $o{':'} ;
      unshift @out , sprintf "%d:%d-%d" , $posC, $posL, $posC - $posC0 + $base if $o{':'} ;
      say join "\t" , @out ; 
    }
    #$posL ++ ;
  }
  say STDERR CYAN ITALIC "Lines: " , $. , RESET '' ; 
}

# 出現した文字の集計表
sub CountChars {
  my %chars ;  # 各文字の頻度を格納
  my %f0l ; # 各文字の最初の出現の行番号
  my %f1l ; # 各文字の最後の出現の行番号
  my $line = 0 ;  # 全体の行数

  while( <> ) { 
    for ( split // , decode ( $_ ) , 0 ) {  
      $chars{ $_ } ++ ; 
      $f0l { $_ } //= $line ;
      $f1l { $_ } = $line ;
    }
    $line ++ ; 
  }

  my @out = ( "freq", "code_point", "char" ) ; 
  push @out , "linum_first" , "linum_last" if $o{':'} ; 
  say UNDERLINE join "\t" , @out ; 
  for( sort {$chars{$b} <=> $chars{$a} } keys %chars ) { 
    my @out = ( $chars{ $_ } , sprintf( "U+%02X" ,ord $_) , sprintf ('[%s]' , norChar $_ ) ) ; 
    push @out , $f0l{$_} + $base , $f1l{$_} + $base if $o{':'} ;
    say join "\t" , @out ;
  }
 
  say STDERR CYAN ITALIC "Lines: " , $line , RESET '' ; 
}


sub VERSION_MESSAGE {} 
sub HELP_MESSAGE { $0 =~ s|.*/|| ; while(<DATA>){s/\$0/$0/g;print $_ if s/^=head1// .. s/^=cut// } exit 0 } 

no utf8 ;
__END__ 

=encoding utf8 

scripts/colchop  view on Meta::CPAN

use List::Util qw [ any ] ; 
eval 'use Text::VisualWidth::UTF8 qw[trim width]; 1' or die 'Be Text::VisualWidth::UTF8 installed.' if $o{v} ; 

* trim = * Text::VisualWidth::UTF8::trim if $o{v} ; # 単に警告を回避するために、次行以外にこの行を挿入。
* trim = $o{v} ? * Text::VisualWidth::UTF8::trim : sub { substr ( $_[0], 0 , $_[1] ) } ; 

$| = 1 if $o{'!'} ; # オートフラッシュの設定　<- -- 必要か?
$o{h} //= 0 ; # 左から何列は手を加えないかを洗わす。
# 出力する文字列の長さの最大値と折り返し数の最大値
my ($tlen, $tmax) = do { ($o{g}//='') =~ m/(\d*)\D?(\d*)/ ; ( $1 || 6 , $2 // 2 || "Inf")  } ; 
#say STDERR $tlen,' ', $tmax;
my $existNext = $o{'.'} // '.' ; # また表示が足りない時に、セル末に挿入する文字列
my $iosep = $o{'/'} // "\t" ; # 入出力の区切り文字

binmode STDIN, ":encoding(utf8)" if ! $o{w} && $o{u} ;   # binmode の指定は、 substr関数に影響する。
binmode STDIN, ":encoding(cp932)" if $o{w} ; # <-- - SJIS <<? "cp932" 絵文字も考えたい
binmode STDOUT,":encoding(utf8)" if $o{u} || $o{w} ;  #$/ = "\r\n" if $o{W} ;

& main ; 
exit ; 

sub aLinOut ( @ ) { 
  my @cells ;
  for ( 1 .. $#_ ) { # 各マスの文字列について..  ( $_ は1始まりで左から何番目かを表す )
    push @cells , undef and next if ! defined $_[$_] ; # 未定義なら未定義として
    my $str = $_ <= $o{h} ? $_[$_] : trim ( $_[$_] , $tlen ) ; # -h で左からいくつかの列は保護する指定があれば、そのようにして ..
    $_[$_] =~ s/^\Q$str\E// ; 
    $_[$_] = undef if $_[$_] =~ m/^$/ ;
    push @cells , $str . ( defined $_[$_] ? $existNext : '' ) ;
  }
  unshift @cells , "$_[0]" if defined $_[0] ;
  say join $iosep , map { $_ // '' } @cells ;  
}

sub main ( ) { 
  while ( <> ) { 
    chomp ; 
    my $lc = "$.:" if $o{':'} ;  # -:  指定で、行番号を1回だけ表示 LineCount
    my @F = split /$iosep/o , $_ , -1 ; 
    #for ( my $t=0 ; ++$t <= $tmax ; ) { aLinOut ($lc, @F) ; $lc = '' ; last if ! any { defined $_ } @F } 
    for ( my $t=0 ; ++$t <= $tmax ; ) { aLinOut $lc, @F ; last if ! any { defined $_ } @F } 
  }

scripts/collen  view on Meta::CPAN

#!/usr/bin/perl 

use 5.014 ; use warnings ; # 5.001だった
use feature qw[ say ] ;
use Time::HiRes qw [ gettimeofday tv_interval ] ;
my ${ dt_start } = [ gettimeofday ] ; 
use Term::ANSIColor qw[ :constants ] ; $Term::ANSIColor::AUTORESET = 1 ; 
END{ $0 =~ s/.*\///;say STDERR DARK BOLD ITALIC YELLOW sprintf "\t--- %0.6f sec calculation ($0)." , tv_interval ${ dt_start } } ; 
use Getopt::Std ; getopts '1cC:f:i:lrs:uv=!^*:@' , \my%o ; # 5.014 で何度も実行済み
use Encode qw[ decode_utf8 encode_utf8 ] ; 
eval 'use Text::VisualWidth::UTF8 qw[ width ] ; 1 ' or die 'Installing Text::VisualWidth::UTF8 is necessary.' if $o{v} ;
use List::MoreUtils qw[ firstidx lastidx ] ;
no warnings ;
* charlen = $o{v} ? * Text::VisualWidth::UTF8::width : sub { length $_[0] }  ; 
use warnings ;
sub mainproc ; # メインの処理

$| = 1 if $o{'!'} ; # オートフラッシュの設定

scripts/collen  view on Meta::CPAN

  while ( <> ) { 
    & preProcN ; # 改行文字の処理
    & preProcU ; # UTF8に関わる処理
    #& sptr ;
    #& preProcS ; # 空白文字についての処理
    @_ = & mainTreat ; 
    & colcnt ; # 条件にあった列の数を数えるような処理 -cが指定されている場合に。
    & incFNa ; #ファイル名を末尾に付加 
    & fmtwdt ; 
    & incOrg ; # 入力した文字列を末尾に付加
    say join $o , @_ ; 
    say "^\t$ARGV" if eof && $o{'^'} ; 
    #do { $| = 1 ; print '' ; $|= 0 } if $. % $o{'*'} == 1 ; 
  } 
} ;


## ヘルプの扱い
sub VERSION_MESSAGE {}
sub HELP_MESSAGE {
    use FindBin qw[ $Script ] ; 
    $ARGV[1] //= '' ;

scripts/colpairs  view on Meta::CPAN

sub showing1 ( ) { 
    my $cols = @{ $pf } ; 
    
    @heads = ( 1 .. $cols ) unless @heads ; #defined $cols 
    my @diag = map { scalar keys %{ $pf -> [$_][$_]}}  0 .. $cols -1 ; 

    # 出力表の表頭
    my @out = ( (BOLD 'pairs') , map { UNDERLINE $_ } 1 .. $cols ) ; 
    push @out , UNDERLINE YELLOW 'col_' . ($o{'='} ? 'name' : 'num')   ;
    push @out , UNDERLINE('minstr') , UNDERLINE('maxstr') if 0 ne ($o{v}//'')  ; 
    say join "\t" , @out ; 

    # 出力表の各行
    my $cell ; # $cell -> [] [] 
    for my $i ( 0 .. $cols - 1 ) { 
        my @out = () ;

        # 表側
        push @out , ($i+1).':' ; #. color('reset') ; # 列番号

        # 右上の部分

scripts/colpairs  view on Meta::CPAN

sub showing2 ( ) { 
    my $cols = @{ $pf } ; 
    @heads = ( 1 .. $cols ) unless @heads ; #defined $cols
    my @diag = map { scalar keys %{ $pf -> [$_][$_]}}  0 .. $cols -1 ;

    # 出力表の表頭
    my @out = ( (BOLD 'freq').'(min-mid-max)' , map { UNDERLINE $_ } 1 .. $cols ) ; 
    push @out , UNDERLINE YELLOW 'col_' . ($o{'='} ? 'name' : 'num')   ;
    push @out , UNDERLINE('q_value') if 0.9 < ($o{v}//'1')  ; 
    say join "\t" , @out ; 

    # 出力表の各行
    my $cell ; # $cell -> [] [] 
    for my $i ( 0 .. $cols - 1 ) { 
        my @out = () ;
        push @out , ($i+1) . ':' ;

        # 左下
        for my $j ( 0 .. $i - 1 ) { 
            my $val = do { my $t = pickN 1, ( qval $pf -> [$j][$i] ) ; $t =~ s/\t/|/r } ; 

scripts/colpairs  view on Meta::CPAN

sub showing3 ( ) { 
    my $cols = @{ $pf } ; 
    @heads = ( 1 .. $cols ) unless @heads ; #defined $cols
    my @diag = map { scalar keys %{ $pf -> [$_][$_]}}  0 .. $cols -1 ;

    # 出力表の表頭
    my @out = ( ( BOLD 'undec' ) , map { UNDERLINE $_ } 1 .. $cols ) ; 
    push @out , UNDERLINE YELLOW 'col_' . ($o{'='} ? 'name' : 'num')   ;
    push @out , UNDERLINE('value_not_determining_other_column_value') if 0.9 < ($o{v}//'1')  ; 
    say join "\t" , @out ; 

    # 出力表の各行
    my $cell ; # $cell -> [] [] 
    for my $i ( 0 .. $cols - 1 ) { 
        my @out = () ;
        push @out , ($i+1) . ':' ;

        # 左下
        my @o2 ; 
        for my $j ( 0 .. $cols - 1 ) { 

scripts/colpairs  view on Meta::CPAN

        my $posj ; # どこで最小値となったのか
        do { $o2[$_] == $tmp and $o2[$_] = BOLD $o2[$_] and $posj //= $_ } for 0 .. $#o2 ; 

        push @out , @o2 ;
        push @out , YELLOW $heads [$i] ; # 列名または列番号を挿入
        my @o3 = sort {  keys %{$pf->[$i][$posj]{$b}}  <=> keys %{$pf->[$i][$posj]{$a}} || $a cmp $b }  @{ $pfijv->[$i][$posj] } ;
        $_ = $_ . FAINT '(' .  (keys $pf->[$i][$posj]{$_} ) .')' for @o3 ; 
        push @out , pickN $o{m}, @o3 ; # @{ $pfijv->[$i][$posj] } ;


        say join "\t" , @out ;

        next ;
        # 対角線の部分
        # push @out, color('bright_green') . (scalar keys %{$pf->[$i][$i]}) . color('reset') ; 
        push @out, 0 ; 

        # 右上
        for my $j ( $i+1 .. $cols -1 ) { 
            my $val =  nonDeterminability ( $i , $j ) ; 
            push @out , $val ;
        }

        push @out , YELLOW $heads [$i] ; 
        say join "\t" , @out ; next ;
    }
}


sub showing4 ( ) { 
    my $cols = @{ $tf } ; 
    @heads = ( 1 .. $cols ) unless @heads ; #defined $cols
    my @diag = map { scalar keys %{ $tf -> [$_][$_][$_]}}  0 .. $cols -1 ;

    # 出力表の表頭

scripts/colsummary  view on Meta::CPAN

sub d3 ($) { $_[0] =~ s/(?<=\d)(?=(\d\d\d)+($|\D))/,/gr } ; # 数を3桁区切りに変換する。
#sub hhmmss () { sprintf '%02d:%02d:%02d' , @{[localtime]}[2,1,0] } ; # 現在時刻を hh:mm:ss の形式で取り出す。

$/ = "\r\n" if $o{w} ; # -r指定で 改行文字をWindows形式に変更。
my $L = ',' ; # 出力によく現れる区切り文字列
my $isep = $o{i} // "\t" ;  # 入力の区切り文字 $o{','} = do { $o{','} //= "\t" ; eval qq[qq[$o{','}]] } ;
my $nc = 0 ; # 計数対象としなかったセルの数をカウント。
my $sec = $o{'@'} // 15 ; # 何秒ごとにレポートを表示させるか
my $rl ; # 各ファイルの読んだ行数を格納。

$SIG{ ALRM } = sub { say STDERR GREEN + (d3 $rl) . " lines read. " , scalar localtime ; alarm $sec } ; 

my ${ INT1 } = sub {
  &{ $SIG{ALRM} } ;
  print STDERR BRIGHT_RED 
   'Do you want to get the halfway result? Then type Ctrl + C again within 2 seconds. '. "\n" .
   'Really want to Quit? Then press Ctrl + "\" or Ctrl + Yen-Mark. (Ctrl+Z may be what you want.) ' . RESET "\n" ;
  $SIG{INT} = sub { select *STDERR ; & ColStat ; select *STDOUT ; return } ; 
  sleep 2 ; 
  return ;
} ;

scripts/colsummary  view on Meta::CPAN

# ヘッダから列名を取得する。 -= が指定された場合のみ
sub colnames ( $ ) { my @F =  split /$isep/, do { my $FH = $_[0] ; my $t = <$FH> ; $rl++ if defined $t ; $t //= '' ; chomp $t ; decode ($t) } , -1 } 

sub filePinfo {
  exit if ($o{2}//'') eq 0 ;
  $rl = d3 ($rl // 0) ; # read lines
  my $procsec = tv_interval ${ dt_start } ;
  my $out = "$rl line(s) read; "; 
  $out .= "$nc cells are not counted; " if $nc ;
  $out .= sprintf '%0.6f seconds (colsummary)', $procsec ; # たまにマイクロ秒単位の$procsecが15桁くらいで表示されるのでsprintf。
  say STDERR BOLD DARK ITALIC CYAN $out ;
}

# 各列の値の分布を取り出す
sub ColFreq ( $$ ) { # 第１変数はファイルハンドル 第２変数は参照
  #my %zstr ; # 除外された文字列の出現頻度。(点検用でもある。)     #my $intflg ; #$SIG{INT} = sub { $intflg = 1 } ; 
  my $maxCols = 0 ;
  my $col = undef ; # 0オリジンのカラム番号
  * lenlim = defined $o{l} ? sub { grep { $_ = substr $_, 0, $o{l} } @_ } : sub {} ; # -l で長さ制限
  * tailspacetrim = defined $o{s} ? sub { grep { s/\s+$// } @_ } : sub {} ; 
  * negcell = defined $o{'#'} ? sub { if (m/$o{'#'}/ ) { $col ++ ; $nc ++ ; goto EACH_CELL } }  : sub {} ; # o{'0'} をやめた

scripts/colsummary  view on Meta::CPAN

  my @p = @_ ; 
  my @P ; 
  push @P , $p[0] ;  ## (1) 列番号の表示1から
  push @P , GREEN BOLD $p[1] ; ## (2) 何通りの値が出現したかを表示 
  push @P , BRIGHT_BLUE $p[2] if ($o{m}//'') ne 0 ; ## (3) 平均値の表示 (加算と減算の関係を把握する目的があるので、値が無いところは0と見なす)
  push @P , BRIGHT_YELLOW $p[3] ;## (4) 列の名前(列名)を表示
  push @P , BRIGHT_WHITE $p[4] ; ## (5) 値の最大と最小を取り出す。
  push @P , $p[5] ;## (6)  具体的な値の表示 (出現度数の多い順に $o{g} 個 ) 
  push @P , BRIGHT_GREEN $p[6] . GREEN $p[7] ;## ## (7) 最頻度数の分布## (7) 中点(なかてん)の処理 (7) テール度数の分布
  push @P , BRIGHT_BLUE $p[8] ;  ## (8) 値の文字列長の範囲の表示
  say join "\t" , @P ;
}

# 平均値を計算する処理をする。
sub aveft ( $$ ) {
  my ($rHash,$rKeys) = @_ ;
  my ($tval, $freq, $asum, $afreq ) ; 
  for( @{$rKeys} ) { 
    ( my $num = $_ ) =~ s/(\d),/$1/g ; #s/,//g ; # 3桁区切りに現れる区切りコンマを消去する
    $tval = POSIX::strtod ( $num ) ; 
    $freq = $rHash->{ $_ }  ; 

scripts/csv2tsv  view on Meta::CPAN

use Time::HiRes qw [ gettimeofday tv_interval ] ;
my ${ dt_start } = [ gettimeofday ] ; 
use Getopt::Std ; getopts '~2ae:n:s:t:vQ@:', \my %o ;
use Text::CSV_XS ;  #  Not a core module.
use FindBin qw [ $Script ] ; 
use Term::ANSIColor qw[ :constants color ] ; $Term::ANSIColor::AUTORESET = 1 ; 
use Encode ;# Encode was first released with perl v5.7.3
#$| = 1 ;
END{
  my $lt = sprintf '%04d-%02d-%02d %02d:%02d:%02d' , do {my @t = @{[localtime]}[5,4,3,2,1,0] ; $t[0]+=1900 ; $t[1]++ ; @t } ; 
  say STDERR CYAN FAINT BOLD tv_interval( ${ dt_start } ) , " seconds spent ($0 $lt)"; 
}

$SIG{INT} = sub { 
 say STDERR YELLOW FAINT BOLD UNDERLINE qq[Analysis using the function of the perl function `caller': ("~" means undefined.)] ;
 for ( 0..59 ) { 
    my @out = caller ($_)  ; 
    last unless @out ; 
    say STDERR YELLOW FAINT BOLD "$_ : " , map { $out[$_] //= '~' ; "[$_] $out[$_] " } 0..$#out ; 

 }
 exit 1 ; 
} ;


grep { $_ = decode_utf8 $_ if defined $_ } $o{e} , $o{t}, $o{n} ;
$o{e} //= qw[ \ ] ;  # エスケープしたい文字列につける文字
$o{s} //= ',' ; # フィールドの区切り文字を指定
$o{'@'} //= 5 ; # 何も入力が無い場合に，何秒おきに警告を出すか

scripts/depthdepth  view on Meta::CPAN

#!/usr/bin/perl 
use 5.014 ; use strict ; use warnings  ;
use feature qw [ say ] ;
use Time::HiRes qw[gettimeofday tv_interval] ; 
use Term::ANSIColor qw [ :constants color ] ; $Term::ANSIColor::AUTORESET = 1 ; 
use File::Spec::Functions qw[ catfile splitdir rel2abs updir ] ; 
use Getopt::Std ; 
use List::Util qw [ max min sum sum0 reduce ] ;
use Cwd qw [ getcwd abs_path ] ;

my $time_start = [ gettimeofday ] ; 
getopts '.:g:x:0:' , \my%o ; 
push @ARGV , $o{x} if defined $o{x} ; # 引数がオプションで  与えられた場合の処理
my $start_dir = $ARGV [0] // "." ; # 先頭のディレクトリ 
my $I = catfile q[] , q[] ;
my $d0 = ( getcwd ) . $I ;
chdir $start_dir or do { say STDERR "Seems no such a directory ``$start_dir''" ; exit -1 }  ;
$d0 = (getcwd ). $I unless exists $o{g} && $o{g} =~ m/a/ ; 
$d0 = '' if exists $o{g} && $o{g} =~ m/A/ ;
#say GREEN  getcwd ; 

sub head_trim ( $ ) {
 (my $t = $_[0]) =~ s/^\Q$d0\E// ;
  $t =~ s/\ /\\ /g ; # <-- 空白文字をエスケープ xargs に渡せるようになる。
 $t ;
}

& main ; 
exit 0 ;

END{ print RESET "" } ;



sub open_dir_error_message ( $ ) { 
  say STDERR FAINT BOLD YELLOW "Cannot open the directory `$_[0]' so skipped." ;
}

# そのインスタンスの下のディレクトリファイルの一覧を文字列の配列で返す。
sub get_dirs () { 
  my @dirs ;
  #return @dirs = grep { -d $_ } glob '*' ; 
  opendir my $dh , '.' or do { open_dir_error_message ( abs_path "." ) ; return () } ; 
  @dirs = grep { ! /\A\.{1,2}\Z/ && -d $_ } readdir $dh ; 
  @dirs = grep { ! /\A\./ } @dirs if exists $o{'.'} && $o{'.'} eq "0" ; # 隠しファイルに関する処理
  closedir $dh ;

scripts/depthdepth  view on Meta::CPAN

sub main () {

  # コンマ区切り ハイフン結合ペアの取り出し
  my @gg = do { ! exists $o{g} ? () : (my $t = $o{g}) =~ s/[Aadlx]//g ;  map { [ split /-/, $_ ] } split /,/ , $t // '' } ;
  our %g1 = map { $_ ->[0] , 1 } grep { @ { $_ } == 1 } @gg ; # ペアではないもの
  our %g2 = map { $_->[0] ."-" .$_->[1] , 1 } grep { @ { $_ } == 2 } @gg ; # ペアのもの

  our @S ; #　$S[depth][maxdepth]の集計表となる。
  our @Sq ;  # $S_ln [ depth ]
  $SIG{INT} = sub { say GREEN getcwd ; & output  } ;
  & node_proc ( 0 ) ; 
  & output () unless exists $o{g} && $o{g} =~ m/x/ ;

  sub node_proc ( $ )  { 
    # 第１引数は、元の指定ディレクトリからの深さであり、
    # 返り値は、そこで経験した最大の深さである。
    my $dep = $_[0] ; # 深さ
    my $mdep = $dep ; # 最大深さの記録用。
    my @dirs ; # = get_dirs () ;
    opendir my $dh , '.' or do { open_dir_error_message ( abs_path "." ) ; return () } ; 
    #@dirs = sort grep { ! /\A\.{1,2}\Z/ && -d $_ && ! -l $_ } readdir $dh ;  # <-- - sort は -g が無いときは不要である
    my @dirs0 = sort grep { ! /\A\.{1,2}\Z/ && -d $_ } readdir $dh ;  # <-- - sort は -g が無いときは不要である
    for ( @dirs0 ) { #reverse 0 .. $#dirs ) {
      if ( -l $_ )
      { 
        say join "\t" , $o{g} =~ m/d/ ? () : "link", head_trim (getcwd).$I.$_ if exists $o{g} && $o{g} =~ m/l/;
        #splice @dirs , $_ , 1 ; 
        ++ $Sq [ $dep + 1 ] ;
        next ;
      } 
      push @dirs , $_ ;
    }
    #@dirs = grep { ! ( -l $_ && ++ $Sq[$dep+1]  ) } @dirs ; 
    #@dirs = grep { ! ( -l $_ ) } @dirs ; 
    @dirs = grep { ! /\A\./ } @dirs if exists $o{'.'} && $o{'.'} eq "0" ; # 隠しファイルに関する処理
    #closedir $dh ;

    for ( @dirs ) { 
      #chdir $dh ;
      next unless chdir $_ ; 
      #chdir $_ ;
      $mdep = max $mdep , & node_proc ( $dep + 1 ) ; # <-- 再帰的な呼び出し
      chdir $dh or die ; # ここで戻れないのは重大
    }
    closedir $dh ;
    $S [ $dep ] [ $mdep ] ++ ;
    say join "\t" , $o{g} =~ m/d/ ? () : $dep, head_trim getcwd if $g1{$dep}  ; 
    say join "\t" , $o{g} =~ m/d/ ? () : "$dep-$mdep", head_trim getcwd if  $g2{"$dep-$mdep"} ; 
        return $mdep ;
  }


  sub output () { 
  my $asum = 0 ; # ファイル数の合計
  my @out = ( '', 0 .. $#S , '+' , '++' ) ;
  push @out , MAGENTA "Symbolic_link_dir" if sum0 map { $_ // 0 } @Sq ;
  say join "\t" , @out ;
  for ( 0 .. $#S ) { 
    $S[$_][$_] //= 0 ; # unless exists $o{0} && $o{0} eq "." ; # 対角成分に対する処理
    for my $i ( $_ ..  $#S ) { $S[$_][$i] //= '' } ; 
    my @out = ( $_ , map { ! defined $_ ? '' : $_ eq '' ? FAINT 0 : $_ } @{$S[$_]} ) ; 
    push @out , FAINT my $rsum = sum0 map { $_ || 0 } @{$S[$_]}   ; 
    push @out , $asum += $rsum ;
    push @out , MAGENTA "+$Sq[ $_ ]" if $Sq [$_] ;

    say join "\t" , @out ; 
  }
}
END{
  say STDERR " --  " , REVERSE ITALIC " Process time: " , CLEAR " " , 
     sprintf( "%.6f", tv_interval $time_start , [ gettimeofday ] ) , " second(s)." ;
   }
}


## ヘルプの扱い
sub VERSION_MESSAGE {}
sub HELP_MESSAGE {
    use FindBin qw[ $Script ] ; 
    $ARGV[1] //= '' ;

scripts/expskip  view on Meta::CPAN

  my $fnFlag = @ARGV > 1 ; 
  while ( 1 ) { 
    my $fn = shift @ARGV  ; # ファイル名
    my $fh ; # ファイルハンドル
    if ( defined $fn ) { 
        open $fh , "<" , $fn or warn "File `$fn' does not open." and next ; 
    } else { 
        $fh = *STDIN ;
    }
    binmode $fh , ":gzip(autopop)" if $o{z}  ; 
    say $fn if $fnFlag ;
    eachFile $fh ; 
    close $fh ; 
    last if ! @ARGV  ;
    print "\n" ; # ファイル間の空行
  }
}

sub eachFile ( $ ) { 
  #$. = 0 ;
  @nums = @nums0 ;

scripts/fileday  view on Meta::CPAN

#!/usr/bin/perl 
use 5.014 ; use strict ; use warnings  ;
use feature qw [ say ] ;
use Time::HiRes qw[gettimeofday tv_interval] ; 
use Term::ANSIColor qw [ :constants color ] ; $Term::ANSIColor::AUTORESET = 1 ; 
use File::Spec::Functions qw[ catfile splitdir rel2abs updir ] ; 
use Getopt::Std ; 
use List::Util qw [ max min sum sum0 reduce uniq ] ;
use Cwd qw [ getcwd abs_path ] ;
use POSIX qw[ strftime ] ;

my $time_start = [ gettimeofday ] ; 
getopts '~.:b:dHMmrSv:x:y' , \my%o ; 
push @ARGV , $o{x} if defined $o{x} ; # 引数がオプションで  与えられた場合の処理
my $start_dir = $ARGV [0] // "." ; # 先頭のディレクトリ 
my $I = catfile q[] , q[] ;
my $d0 = ( getcwd ) . $I ;
chdir $start_dir or do { say STDERR "Seems no such a directory ``$start_dir''" ; exit -1 }  ;
$d0 = (getcwd ). $I unless exists $o{g} && $o{g} =~ m/a/ ; 
$d0 = '' if exists $o{g} && $o{g} =~ m/A/ ;
& main ; 
exit 0 ;

END{ print RESET "" } ;

sub main () {

  our $fmt = $o{y} ? "%Y" : $o{m} ? "%Y-%m" : $o{d} ? "%Y-%m-%d" : $o{H} ? "%Y-%m-%dT%H"
           : $o{M} ? "%Y-%m-%dT%H:%M" : $o{S} ? "%Y-%m-%dT%H:%M:%S"  : "%Y-%m-%d" ;

  & node_proc ( 0 ) ; 
  & output () ;

  sub open_dir_error_message ( $ ) { 
    say STDERR FAINT BOLD YELLOW "Cannot open the directory `$_[0]' so skipped." ;
  }

  sub node_proc ( $ )  { 
    # 第１引数は、元の指定ディレクトリからの深さであり、
    # 返り値は、そこで経験した最大の深さである。
    my $dep = $_[0] ; # 深さ
    my $mdep = $dep ; # 最大深さの記録用。
    our ( %nA , %nM, %nC ) ; #ファイルの個数を時間のビン毎に記録する
    our ( %bA , %bM, %bC ) ; #ファイルのバイト数の合計を時間のビン毎に記録する

scripts/fileday  view on Meta::CPAN

      $mdep = max $mdep , & node_proc ( $dep + 1 ) ; # <-- 再帰的な呼び出し
      chdir $dh or die ; # ここで戻れないのは重大
    }
    closedir $dh ;
    return $mdep ;

  sub output () { 

    my @t0 = ( "when" , "#accessed" , "#modified" , "#created" )  ;
    push @t0 , "byteSum_A" , "byteSum_M" , "byteSum_C" unless exists $o{b} && $o{b} eq "0" ;
  	say join "\t" , @t0 ;
 	my @k = uniq sort keys %nA , keys %nM, keys %nC ;	
 	@k = reverse @k if $o{'~'} ;
 	for ( @k ) { 
 		my @t = ( $_ , $nA{$_} , $nM{$_} , $nC{$_} ) ; 
 		push @t ,  $bA{$_} , $bM{$_} , $bC{$_} unless exists $o{b} && $o{b} eq "0" ;
 		say join "\t" ,  map {$_ //'' }  @t ;
 	}
  }


  }


  END{
  	exit if exists $o{v} && $o{v} eq "0" ;
    say STDERR " --  " , REVERSE ITALIC " Process time: " , CLEAR " " , 
     sprintf( "%.6f", tv_interval $time_start , [ gettimeofday ] ) , " second(s)." ;
  }
}

## ヘルプの扱い
sub VERSION_MESSAGE {}
sub HELP_MESSAGE {
    use FindBin qw[ $Script ] ; 
    $ARGV[1] //= '' ;
    open my $FH , '<' , $0 ;

scripts/freq  view on Meta::CPAN

my @givenL ;   
my %gl ; # 個数を数える対象を指定されて場合は、それを読み取る。(Given List)

my ($hTake, $tGet) = $o{x} =~ m/\d+/g if defined $o{x} ; # -xのオプションから数値を最大2個取り出す
$tGet //= 12 ; ## 画面を溢れないように制限した

my $sec = $o{'@'} // 15 ; # 何秒おきにアラームを発生させるか

$SIG{ALRM} = sub { 
  my $n = $.  =~ s/(?<=\d)(?=(\d\d\d)+($|\D))/,/gr ; # 3桁ごとに区切る。
  say STDERR GREEN "$n lines read ($Script). " , scalar localtime ; 
  alarm $sec 
} ; 
sub IntFirst {
  &{ $SIG{ALRM} } ;
  print STDERR BRIGHT_RED 
   'Do you want to get the halfway result? Then type Ctrl + \ again within 2 seconds. '. "\n" .
   'Really want to Quit? Then press Ctrl + "\" or Ctrl + Yen-Mark after 2 seconds later. ' . RESET "\n" ;
  local $SIG{QUIT} = sub { select *STDERR ; & output ; select *STDOUT } ;
  sleep 2 ; # eval { local $SIG{ALRM} = sub { alarm $sec ; die } ; alarm 2 ; 1 while 1  } ; 
  #$SIG{INT} = 'IntFirst' ;

scripts/freq  view on Meta::CPAN

  # 書き出し
  #my $header ; 
  my @cNames ;  # 最初の行に出力するリスト
  push @cNames , "Lin#Range"  if $o{':'} ; 
  push @cNames , "CumRat"  if $o{a} && $o{'%'} ;
  push @cNames , "AccSum"  if $o{a} ;
  push @cNames , "Ratio"  if $o{'%'} ; 
  push @cNames , "Freq*" unless $o{1} ;
  push @cNames , $first // "LinStr" ; # unless defined $first ; 
  push @cNames , "RIGHT_FIELDS.." if defined $hTake ;
  say UNDERLINE join $o , @cNames if ($o{0}//'') ne '0' ; 

  * lineRange = sub { $strfst{$_} //= 0 ; $strlst{$_} //= 0 ; "$strfst{$_}-$strlst{$_}:" } ; 
  * accOutput = sub { $cumsum += $strcnt { $_ } ; $o{'%'} ? $cumsum . sprintf( "\t%5.2f%%", 100.0 * $cumsum / $totalSum) : $cumsum } ;

  for ( @K ) { 

    sub tailx {
      my @keys = sorting ( $cntX1X2 { $_ } ) ; 
      @keys = splice @keys , 0, $tGet if defined $tGet ;
      my $out = '' ; 
      #say STDERR "@keys" ; # = sort { $cntX1X2{$_}{$a} <=> $cntX1X2{$_}{$b} } @keys 
      @keys = sort { $cntX1X2{$_}{$b} <=> $cntX1X2{$_}{$a} } @keys ;
      for my $k ( @keys ) { $out .= "\t[$k]x$cntX1X2{$_}{$k}" } ; 
      return $out ; 
    }

    $strcnt{ $_ } //=  0 ;
    next unless y_filter ( $strcnt{$_} ) ; 
    print & lineRange, "\t" if exists $o{':'} ; # -: オプションにより、どの行番号で現れたのかを出力。
    print & accOutput, "\t" if exists $o{a} ; # -s オプションにより、累和を表示。 
    printf "%5.2f%%$o", 100.0 * $strcnt{$_} / $totalSum if $o{'%'} ;  

scripts/headomit  view on Meta::CPAN

#!/usr/bin/perl
use 5.014 ; use strict ; use warnings ; 
use Getopt::Std ; getopts ':!_12cfh:t:v' , \my%o ;
use Term::ANSIColor qw[ :constants ] ; $Term::ANSIColor::AUTORESET = 1 ;
use FindBin qw[ $Script ] ; 
use feature qw[ say ] ;
sub subinfo ( )  ;
sub show ; 

$o{h} //= 1 ; 
my $fc = 0 ; # それまでに読んだファイルの数 (file count)
my $pc = 0 ; # 標準出力に出力した行数 (print count)
my $ic = 0 ; # 入力した行数 (input count)

$| = 1 if $o{'!'} ;

scripts/headomit  view on Meta::CPAN

    LOOP_END :
    if ( eof ) {
      @s = () ; 
      & flag_c ; #do{ $ic += $. ; $. = 0 } if ! $o{c} ; 
      $fc ++ ; 
      unless ( eof () ) { # 最後のフォルダで無い限り
      	#do { my $t = <> for 1 .. $o{h} } if ! $o{2} ;
        START2 : 
        exit if eof () ;
        do { do { my $t = <> ; if (eof) { ++$fc ; &flag_c ; goto START2 } } for 1.. $o{h}  } if ! $o{2} ;
      	say '' if $o{'_'} ;

      }  
    }
  }	 
}

sub d3 { $_[0] =~ s/(?<=\d)(?=(\d\d\d)+($|\D))/,/gr } 
sub subinfo ( ) { 
  $ic += $. ; 
  $_ = d3 $_ for $ic, $pc, $fc ;

scripts/lastaccess  view on Meta::CPAN

#!/usr/bin/perl
use 5.014 ; use strict ; use warnings ; 
use File::Find ; 
use Time::HiRes qw[ stat tv_interval time gettimeofday ] ;
use Getopt::Std ; getopts ',:d:g:x:',\my %o ; 
use Term::ANSIColor qw[ :constants ] ; $Term::ANSIColor::AUTORESET = 1 ;
use Pod::Perldoc ;
use feature qw[ say ] ;

$o{d} //= 1 ; # ディレトクリに対する処理を抑制するかどうか。0が明示的に与えられたら抑制。
$o{g} //= 12 ; # 最近アクセスされたファイルを最大何個取り出すか
my $start_time = [ gettimeofday ] ;
main () ; exit 0 ;

sub main { 
	my @sdir = defined $o{x} ? ($o{x}) : @ARGV ? @ARGV : qw[ . ] ; 
	our @ Files = () ;  

scripts/lastaccess  view on Meta::CPAN

		my @s = stat $_ ;
		my $atime = $s[8] ;
		my $bytes = $s[7] ; 
		push @ Files , ff->new ( $_ , $atime, $bytes ) if ! ( -d _ && do { $_.='/' ;1} ) || $o{d} ; 
	}  

	my $now = time ; 
    $_ ->{ elapsed } = $now -  $_->{atime} for  @Files  ; 
	@ Files = sort {  $a ->{elapsed} <=> $b->{elapsed} } @Files ; 

	say join "\t", "Diff_seconds", "Seconds_before", "Byte_size", "File_name" ; 
	my $mrec0 = 0 ; 
	my $shown = 0 ;
	for ( splice @Files , 0 , $o{g} ) { 
		my @t ; 
		my $mrec = $_->{elapsed} ; 
		push @t , sprintf "%0.6f" , $mrec - $mrec0 ;
		push @t , sprintf "%0.6f" , $mrec ; 
		push @t , $_->{bytes}, $_->{name} ; 
		$t[2] =~ s/(?<=\d)(?=(\d\d\d)+($|\D))/,/g if $o{','} // '' ne "0" ; 
		say join "\t" , @t ;
		$shown ++ ; 
		$mrec0 = $mrec ; 
	}
	my $num = @ Files ; 
	my $elps = sprintf "%.6f" , tv_interval $start_time ; 
	say STDERR CYAN "Files processed : $num ; Shown above : $shown ;  Elapsed seconds : $elps" ;
}

sub HELP_MESSAGE { # <-- - サブコマンドが呼ばれているときはそのヘルプが呼ばれる。
    local @ARGV = do { my ($x,@y) = 0 ; 1 while ( @y = caller $x++ )[ 0 ] eq "Getopt::Std" ; $y[1] } ;
    Pod::Perldoc -> run ;
}
sub VERSION_MESSAGE { $ Getopt::Std::STANDARD_HELP_VERSION = 1 }  # <- here?


package ff ;

sub new ( $ ) { #say 1 ;
	my $ins = { name => $_[1] , atime => $_[2] , bytes => $_[3] } ; 
	return bless $ins ;
} 

=encoding utf8

=head1 NAME

 lastaccess DIRNAME 

scripts/quantile  view on Meta::CPAN

    chomp ;
    & layer ; 
    push @{ $VV{ $layer } } , $_ ; 
    $LL ++ ; 
  }
  alarm 0 ;
  do { * STDOUT = * STDERR ; HELP_MESSAGE () ; exit } if $. == 0 ; # 読取りが0行ならば、ヘルプを出す。
}

sub proc_out ( ) { 
  say UNDERLINE join "\t" , @xco , 'num' , $o{L} ? 'Layer' : '' ;   # 出力表の表頭
  do { @V = @{ $VV{$_} } ; LayerOut ( $_ ) } for sort keys %VV ; # 出力表の中身 # <-- - ソートの仕方に数値ソートのオプションが欲しい。
}

sub LayerOut ( $ ) {  # 出力各行についての処理 :
  our $layer = $_[0] ; 
  our $Vd = $#V ; # divisionの数
  @V = $o{s} ? sort @V : sort { $a <=> $b } @V ;

  sub LineOut ( &$ ) { # 出力1行の処理内容
    say join "\t", map ( $_[0]->($_) + 0, @xco ) , ($Vd+1) . $_[1] , $layer if!$o{s} ;
    say join "\t", map ( $_[0]->($_) .'', @xco ) , ($Vd+1) . $_[1] , $layer if $o{s} ; # dualvar 対策で冗長になってしまった。
  } 
  # 分位点の計算法 (概念的に考えられる低い方の値、高い方の値、線型補間、単純に近い値)
  sub low_val  ( $ ) { $V[ floor $_[0] * $Vd / $Q ]       } ; 
  sub high_val ( $ ) { $V[ ceil  $_[0] * $Vd / $Q ]       } ; 
  sub near_val ( $ ) { $V[ floor $_[0] * $Vd / $Q + 0.5 ] } ; # 四捨五入法となる.
  sub intp_val ( $ ) { my $x=$_[0]*$Vd/$Q ; my $x1=floor $x ; my $x2=ceil $x ; my $f1=$x-$x1 ; $V[$x1]*(1-$f1)+$V[$x2]*$f1 } 

  LineOut ( \& high_val , '+' ) if $o{h} ; # 上側の値
  LineOut ( \& near_val , ''  ) if!$o{0} ; # 通常の中間の値  ( -0が指定されたら、通常の値は出力しない。)
  LineOut ( \& intp_val , 'i' ) if $o{I} ; # 線型補間値で出力
  LineOut ( \& low_val ,  '-' ) if $o{l} ; # 下側の値

  say BOLD join "\t" , & SelfWeight() , $layer if $o{w} || $o{3} ;
  sub SelfWeight () { 
    #my $total = sum0 @V ; 
    my $total = sum0 map { $_ . '' } @V ; # dualvarの場合、文字列として格納された方(重み)だけが足される
    my @ths = map { $total * $_ / $Q } @xco ; # 閾値
    my ( $t, $t_ ) = ( 0 , 0 )  ; # 途中の合計
    my @ret ; # 結果の格納用
    my $i = 0 ; # 引数
    do { push @ret , $V[0] ; $i++ } if $ths[0] == 0 ; #<-- 0の代わりにV[0]を代入。ここだけ特別で、便宜上のもの。よくない。
    LOOP : 
    for ( @V ) { 

scripts/quantile  view on Meta::CPAN

}

sub Info2ndry ( ) { 
  $LL ++ ; 
  $LL =~ s/(?<=\d)(?=(\d\d\d)+($|\D))/,/g ; # 3桁毎にコンマで区切る
  my $out = '' ; 
  $out  = CYAN "[$Script] read lines : " ; 
  $out .= BRIGHT_CYAN $LL ; 
  $out .= CYAN "  (" . tv_interval ($time0) . " sec.) " ; 
  $out .= BRIGHT_CYAN $Q . CYAN " divisions." ;
  say STDERR $out ; 
} 

=encoding utf8 

=head1

 $0 -/ 分位分割数 

  分位点を求める。通常の(線形)補間値のみならず、上側の値と下側の値も出力する。
  2次情報として何個の値を入力から読み取ったかも、標準エラー出力に出力。

scripts/samesize  view on Meta::CPAN

#!/usr/bin/perl 
use 5.014 ; use strict ; use warnings  ;
use feature qw [ say ] ;
use Time::HiRes qw[gettimeofday tv_interval] ; 
use Term::ANSIColor qw [ :constants color ] ; $Term::ANSIColor::AUTORESET = 1 ; 
use File::Spec::Functions qw[ catfile splitdir rel2abs updir ] ; 
use Getopt::Std ; 
use List::Util qw [ max min sum sum0 reduce uniq ] ;
use Cwd qw [ getcwd abs_path ] ;
use POSIX qw[ strftime ] ;
#use Digest::SHA1 qw[ sha1 sha1_hex sha1_base64 ]; 
use Digest::MD5  qw(md5 md5_hex md5_base64);

sub dtwhen ( $ ) ;

my $time_start = [ gettimeofday ] ; 
my $t0 = $time_start -> [0] ;

#say dtwhen ( $t0 ) ;
getopts '0:2b:Df:nos' , \my%o ; 

my @files = @ARGV ? @ARGV : glob '*' ;

$o{2} = 1 if $o{D} ; # <--- 要注意。 不用意のこの行はコメントアウトや除去をしないように。
$o{0} //= 1 ; # <--- 要注意。 不用意のこの行はコメントアウトや除去をしないように。
& main ; 
exit 0 ;

END{ print RESET "" } ;

sub main () {

  my %s2f ;
  for ( @files ) {
  	next if -d $_ ;
  	my $size = ( lstat $_ ) [7] ; # <--  -- lstat で良いのか
  	next if defined $o{b} && $size < $o{b} ;
  	push @{$s2f{$size}} , $_ ;
  	my @out = ( $size , $_ ) ;
  	#say join "\t" , @out ;
  }

  my $least = $o{f} // 2 ; # ? 1 : 2 ;
  my @sizes  = sort {$a<=>$b} grep {  @{ $s2f { $_ } } >= $least } keys %s2f ; 
  my $nfmt = do { my $t = max @sizes , 0 ; my $d = length "$t" ; "%${d}s" } ; # <-- %${d}u ?? 
  for my $size ( @sizes ) { 
  	#next if @{ $s2f{$size} } == 1 ;
  	my @files = sort @{ $s2f{$size} } ; # ファイルの一覧
  	@files = sort {(stat $a)[9] <=> (stat $b)[9] } @files if $o{n} // $o{o} ;
  	@files = reverse @files if $o{n} ;

scripts/samesize  view on Meta::CPAN

	    $ctx->addfile( $FH );
	  #while ( <$FH> ) { $ctx -> add ( $_ ) }
	    close $FH ;
	  }

	  utime @t3[0,1] , $_ unless $o{0} ; # <- -- --- 時刻情報を破壊するので注意。もしくは秒の小数点以下の情報が消える。
      my $digest = $o{0} ? '---' : $ctx->hexdigest ;
      next if $o{2} && ! $seenD{ $digest } ++ ;
      if ( $o{D} && ! $o{0} ) { unlink $_ ; next } ; 
  	  my @out = ( sprintf ($nfmt , $size)  , $digest , map ( dtwhen $_ , @t3 ) , $_ ) ;
  	  say join "\t" , @out ;

  	}
  }
}

sub dtwhen ( $ ) { 

	my $fmt = abs ( $_[0] - $t0 ) >= 86400 * 180 ? '%Y-%m-%d' : $o{s} ? '%m-%d %H:%M:%S' : '%m-%d %H:%M';
	strftime $fmt , localtime $_[0] ;
}



END{
  exit if exists $o{v} && $o{v} eq "0" ;
  say STDERR " --  " , REVERSE ITALIC " Process time: " , CLEAR " " , 
  sprintf( "%.6f", tv_interval $time_start , [ gettimeofday ] ) , " second(s)." ;
}

## ヘルプの扱い
sub VERSION_MESSAGE {}
sub HELP_MESSAGE {
    use FindBin qw[ $Script ] ; 
    $ARGV[1] //= '' ;
    open my $FH , '<' , $0 ;
    while(<$FH>){

scripts/summing  view on Meta::CPAN

#!/usr/bin/perl
use 5.014 ; use strict; use warnings;
use Time::HiRes qw [ gettimeofday tv_interval ] ;
my ${ dt_start } = [ gettimeofday ] ; 
use Scalar::Util qw/looks_like_number/;
use Getopt::Std; getopts "=~1:c:f:ghqu", \my%o;
use Term::ANSIColor qw[ :constants ] ; 
use feature qw[ say ] ; 
sub readInput () ;  # 入力の読取り 
sub printOutput () ; # 出力の書き出し

eval { use bigint qw[ hex ]} if $o{h} ;

$| = 1 unless $o{u} ;
my $sum = 0 ; # 求めたい合計値
my $lln = 0 ; # 加算対象となった行の数
my $nlln = 0 ; # 非加算対象の行の数
my $header = undef ; # -= が指定された場合にヘッダ行を格納。

my $fp = $o{f} >=0 ? $o{f} - 1 : $o{f} if defined $o{f} ; # どの列を抽出するか
my $fps = $fp >=0 ? $fp + 1 : 0 if defined $o{f} ; # splitで使う。

my ${ ctrl_c } = sub { 
  $Term::ANSIColor::AUTORESET = 0 ; 
  my $lt = sprintf '%04d-%02d-%02d %02d:%02d:%02d' , do {my @t = @{[localtime]}[5,4,3,2,1,0] ; $t[0]+=1900 ; $t[1]++ ; @t } ; 
  my $ln = $. ; $ln =~ s/(?<=\d)(?=(\d\d\d)+($|\D))/,/g ; # 3桁毎にコンマで区切る 
  say ITALIC DARK BOLD sprintf " The current result ($lt): %s lines have been processed." , $ln ;
  printOutput ; 
  say YELLOW 'Push Ctrl+\ or Ctrl+Z to stop the calculation.' ;
  print RESET '' ;  
}  ;

readInput ;
printOutput ; 
exit 0 ; 

sub readInput () { 
  chomp ( $header = <> ) if $o{'='} ; # ヘッダ行
  $SIG{ INT } = $ { ctrl_c }  ;

scripts/summing  view on Meta::CPAN

  #my $org ; # 入力の元の文字列
  * orgStore = defined $o{1} && $o{1} ? sub { @_ =  ($_) } : sub { @_ = () } ; 
  * colChoose = defined $fp ? sub { $_ = [ split ] -> [ $fp ] }  : sub {  } ; 
  * caseHex = defined $o{h} ? sub { $_ = hex $_ } : sub {} ; 
  * outOfCount = defined $o{c} && $o{c} == 0 ? sub {  } : sub { do { $nlln ++ ; goto LOOP } if ! & get_num } ; 
  * theSumming = $o{h} ? sub { $sum += $_ } : sub { $sum = "$sum" + "$_" } ;
  * get_num  = $o{g} ? sub {   m/[-\.\d]+/ ; $_ = $& ; looks_like_number $_  } : sub { looks_like_number $_ }  ;
  * progress = defined $o{1} && $o{1} eq '0' ? sub { () } :
      ! $o{'~'} ? sub{ s/(^|[^0123456789.eEfF+-])(\d+)/$1+$2/g ; "$sum"."\t<= $_" } : # eEfFなどとある部分はこれで良いのか?
      sub { s/(^|[^+-0123456789.eEfF+-])(\d+)/$1+$2/g ; "$_\t"."=> $sum" } ; 
  * doPrint = defined $o{1} && $o{1} eq '0' ? sub { } : sub { say join "\t" , @_ } ; 
      
  LOOP : while( <> ) {
    chomp ;
    & orgStore ;
    & colChoose ; 
    & caseHex ;
    & outOfCount ; # LOOPにジャンプすることがある。
    & theSumming ; # <-- ここで足し算の計算をする
    #$sum = "$sum" + "$_"  ;
    #$sum = "$sum + $_  ;

scripts/summing  view on Meta::CPAN

sub printOutput () { 
  #my $FH = $o{1} ? \* STDOUT : \*STDERR ; # <-- 意味があったのか???
  select $o{1} ? \* STDOUT : \*STDERR ; # <-- 意味があったのか???
  print  $o{q}? '' : 'header=' , qq{'$header'\t} if $o{'='} ;
  my $fmt = $o{q} ? "%s\t%d\t%g\t%s" : "%s <- sum ;\t%d + %d <- counted + not ; \t%s <- average ;" ;
  #$fmt = "%50X <- sum ;\t%d + %d <- counted + not ;" if $o{h} ; 
  my $quot = $lln != 0 ? $sum/$lln : "NaN" ;
  if ( "$quot" > $quot ) { $quot = "$quot" . '..(-)' } 
  elsif ( "$quot" < $quot ) { $quot = "$quot" . '..(+)' }
  #if ( $o{h} ) { say sprintf( & hex8 ( $sum)  ; return } ;
  $sum = & hex8 ( $sum ) if $o{h} ; 
  say sprintf ($fmt , $sum, $lln, $nlln , "$quot") , sprintf "\t%0.6f sec calculation (summing)." , tv_interval ${ dt_start } ; 
}

sub hex8 { 
  my @out = '' ;
  my $n = $_ [0] ; $n = 0 if $n eq "NaN" ;
  my $c = 12 ; 
  do {my $t = $n % 16**8 ; $n = int $n /16**8 ; unshift @out , sprintf "%08x" , $t ; say $n } while ($n != 0 && $c--) ;
  my $out = join " " , @out ;
  $out =~ s/^00+/0x 0/; 
  return $out ;
}


sub VERSION_MESSAGE {}
sub HELP_MESSAGE{
    use FindBin qw[ $Script ] ;
    $ARGV[1] //= '' ;

scripts/venn  view on Meta::CPAN

      if ( eof ) { $N++ ; my $dummy = <> if $o{'='} && ! eof() ; last } ; 
  }
  while ( <> ) { 
      chomp ; 
      $fq[$N]{$_} ++ if exists $fq_{$_} ;
      #$fq_{$_} ++ ;
      if ( eof ) { $N++ ; my $dummy = <> if $o{'='} && ! eof() } ; 
  }

  # Printing
  say join "\t", "*", (map {"file$_"} 1 .. $N) ; # , $flag_v0 ? () :  ('strmin','strmax') ; 
  #my @out ; 
  #push @out , scalar keys %fq_ ; 
  say join "\t" , 'freq' , map { sum0 values %{$fq[$_]} }  0 .. $N-1 ;
  say join "\t" , 'card' , map { scalar keys %{$fq[$_]} }  0 .. $N-1 ;
  #for my $B ( sort { $a <=> $b } keys %bfq_ ) { 
  #    my @out = map { $_ // 0 } map { $bfq { $B } [$_] } 0 .. $N -1   ;
  #    push @out , $bfq_min{$B} , $bfq_max{$B}  if ! $flag_v0 ;
  #say join "\t" , $bfq_{$B} , @out ; #, 
  #}

}


sub read_all 
{
  # READING 
  my $dummy = <> if $o{'='} ;
  while ( <> ) { 

scripts/venn  view on Meta::CPAN

      my @which = grep { exists $fq[$_]{$k} } 0 .. $N-1 ; # その文字列をどのファイルが持つか
      my $B = sum0 map { 1 << $_ } @which ; # ビットパターン
      $bfq_ { $B } ++ ; 
      $bfq { $B } [ $_ ] += $fq [ $_ ] { $k } for @which ; 
      next if $flag_v0 ;
      $bfq_min{$B} //= $k ; $bfq_min{$B} = $k if $bfq_min{$B} gt $k ; 
      $bfq_max{$B} //= $k ; $bfq_max{$B} = $k if $bfq_max{$B} lt $k ; 
  }

  # Printing
  say join "\t", "card3lity", (map {"file$_"} 1 .. $N) , $flag_v0 ? () :  ('strmin','strmax') ; 
  for my $B ( sort { $a <=> $b } keys %bfq_ ) { 
      my @out = map { $_ // 0 } map { $bfq { $B } [$_] } 0 .. $N -1   ;
      push @out , ($bfq_min{$B} ne $bfq_max{$B})? ($bfq_min{$B} , $bfq_max{$B}) : $bfq_min{$B} if ! $flag_v0 ;
      say join "\t" , $bfq_{$B} , @out ; #, 
  }
}

sub secondary_info 
{ 
  my $procsec = tv_interval ${ dt_start } ; #time - $time0 ; # このプログラムの処理にかかった秒数。比較する2個の時刻は秒単位なので、±1秒未満の誤差は発生する。
  * d3 = sub { $_[0] =~ s/(?<=\d)(?=(\d\d\d)+($|\D))/,/gr } ;
  print STDERR BOLD ITALIC DARK CYAN & d3 ( $. ) . " lines processed. " ; 
  print STDERR BOLD ITALIC DARK CYAN "($Script ; " . $procsec . " sec.)\n" ;
}

scripts/xlsx2tsv  view on Meta::CPAN

#!/usr/bin/perl 
use 5.014 ; use warnings  ;
use feature qw [ say ] ;
use Time::HiRes qw[gettimeofday tv_interval] ; my ${ dt_start } = [ gettimeofday ] ; 
use Term::ANSIColor qw [ :constants color ] ; $Term::ANSIColor::AUTORESET = 1 ; 
use Getopt::Std ; getopts '2:d:n:s:x:' , \my%o; 

#use File::Spec::Functions qw[ catfile splitdir rel2abs updir ] ; 
use POSIX qw[ strftime ] ;
use Spreadsheet::XLSX ; 
use Text::Iconv ;
use Encode qw[ decode encode_utf8 ] ; 
sub n2Xcol ($) { my $c = $_[0] ; my $t='A' ; $t++ while $c-- ; $t } # 数値をA,..,Z,AA,..ZZ,AAA. に変換する関数。効率は良くない。
sub nl2some ($)  { ! defined $o{n} ? $_[0] // '' : do { $_ = $_[0] // '' ; s/\r\n/$o{n}/gr } } # セル内改行を適当に置きかえる。

my ${ sheet_num } = 0 ; # シートの枚数
my ${ sheet_name } = "" ; 
my ($r1, $r2 , $c1 , $c2 ) ; # 処理したシート内での左上と右下の座標
my $filename = $o{x} // $ARGV[0] // do { say STDERR BOLD DARK YELLOW "Specify a '.xlsx' file:" ; say glob '*.xlsx' ; exit 1 }  ; 
END{ 
  my @out ;
  push @out , "$sheet_num sheet(s) in '$filename'" ;
  $r1++; $r2++; $c1++; $c2++ ; # 最後なので破壊的な操作を加えた。
  $sheet_name = encode_utf8 $sheet_name ; 
  push @out , "processed sheet: '$sheet_name' with Row: $r1..$r2, Col: $c1..$c2" ;
  push @out , sprintf "%0.6f sec calculation (%s)." , tv_interval ( $dt_start ) , $0 =~ s/.*\///r ;
  push @out , sprintf 'done %04d-%02d-%02d %02d:%02d:%02d' , do {my @t = @{[localtime]}[5,4,3,2,1,0] ; $t[0]+=1900 ; $t[1]++ ; @t } ; 
  say STDERR DARK BOLD ITALIC GREEN join "; " , @out if ! $o{2}//'' eq '0'
} 

# 文字コードの指定の一覧: 
##  いろいろな実験をしたので、その時に使った文字コードを残す意味で、配列のような形で実験に使った文字コードを残す。1 で左から2番目を採用していることを示す
###   ローマ数字 : Ⅰ, Ⅱ, Ⅲ, Ⅴ ; 丸数字 : ①②⑲⑳ ;  全角ハイフンマイナス － ; 
my ${ cc4out }   = ':utf8' ;
my ${ cc4iconv } = qw[ shift_jisx0213 cp932 windows-1251 utf-8 ] [1] ; # エクセルファイルを開く際に用いるが、iconv逆方向なのが気になる。
my ${ cc4sheet } = qw[ Shift_JIS cp932 ] [1]; # シート名の文字列の、文字コード変換に用いる。
my ${ cc4cell }  = qw[ ms932 cp932 Shift_JIS ] [1] ; # 各セルの文字列の、文字コード変換に用いる。ローマ字、丸数字、全角ハイフンマイナスで..

scripts/xlsx2tsv  view on Meta::CPAN

exit ;

sub main () { 
  my $converter = Text::Iconv -> new ("utf-8", ${ cc4iconv } ); # 1251 ---> 932 (shift_jis)
  my $excel = Spreadsheet::XLSX -> new ( $filename , $converter ) ; # (1)
  my @sheets = @{ $excel ->{ Worksheet } } ;  # (2)
  
  # シートの枚数を取り出す
  $o{d} //= '' ;
  ${ sheet_num } = @sheets ; 
  do { say scalar @sheets ; exit if ! defined $o{s} } if $o{d} =~ m's'i ; 

  ## まずシートを取り出す。-s が無ければシート名一覧を取得してすぐに終了。
  binmode STDOUT, ${ cc4out } ; # この分は$filenameの格納する文より後ろに来る。

  $o{s} = $o{s} || do { say for (GREEN 'The sheet names:'), map { decode ${ cc4sheet } , $_ -> { Name } } @sheets ; exit } ; 
  my $s = $sheets [ $o{s} - 1 ] ; # あるシートを表すオブジェクト
  ${ sheet_name } =  decode ${ cc4sheet } , $s -> { Name } ;
  # -dのパラメータに従ってテーブルの行と列の範囲を取り出す。
  ($r1, $r2 , $c1 , $c2 ) = ( $s->{MinRow} , $s ->{MaxRow} , $s -> {MinCol} , $s -> {MaxCol} ) ; # (3)
  say $r1+1 , ".." , $r2+1  if $o{d} =~ '1' ; # 行範囲の出力
  say $c1+1 , ".." , $c2+1  if $o{d} =~ '2' ; # 列範囲の出力
  say n2Xcol $c1 , ".." , n2Xcol $c2  if $o{d} =~ m'A'i ; # -A指定で、列範囲を A,..,Z,AA..ZZで換算して表示
  exit if $o{d} =~ m/0/ || defined $o{p} && $o{p} eq '0' ; 
  
  # セルの中身を取り出す
  for my $r ( $r1 .. $r2 ) { 
    my @line = map { nl2some decode ${ cc4cell } , $_ -> { Val } } map $s->{Cells}[$r][$_] , $c1 .. $c2 ;  # (4)
    say join "\t" , map $_ // '' , @line ; 
  }
}
 
## ヘルプの扱い
sub VERSION_MESSAGE {}
sub HELP_MESSAGE {
    use FindBin qw[ $Script ] ; 
    $ARGV[1] //= '' ;
    open my $FH , '<' , $0 ;
    while(<$FH>){