view release on metacpan or  search on metacpan

scripts/matrixpack  view on Meta::CPAN

#!/usr/bin/perl
use 5.014 ; use strict ; use warnings ; 
use Getopt::Std ; getopts '1ah/:' , \my%o ; 
use Term::ANSIColor qw[:constants] ; $Term::ANSIColor::AUTORESET =  1 ;
use Scalar::Util qw[looks_like_number] ; 
use FindBin qw[$Script] ; 
BEGIN{
print STDERR BRIGHT_RED qq["$ARGV[0]" may be given as a file although it should consist of column numbers.\n] if -f $ARGV[0] ;
}
my @cols = split /[,\n\t]/, shift @ARGV , 0 ; # 指定された列が @cols に格納される。
do { print STDERR BRIGHT_RED "[$Script] Numbers is not specified: @cols\n" ; exit 1 } if grep {! looks_like_number $_ } @cols ;
do { print STDERR BRIGHT_RED "[$Script] Only 0 is specified: @cols\n" ; exit 1 } unless grep { $_ != 0} @cols ;

my $sep = $o{'/'} // "\t" ; 
my @ca = @cols ; # @colsが作業用に格納され、処理中に使われる。
do{ select STDERR ; &HELP_MESSAGE } unless @cols ; 
$o{h} ? & takehead : & packing ; 
do { print "\n" for @ca } if $o{a} ; 
exit 0 ; 

sub takehead { 
  while ( <> ) { 
    my $c = shift @ca ; 
    do { last if $o{1} ; @ca = @cols ; $c = shift @ca } if ! defined $c ; 
    chomp ; 
    my @F = split /$sep/,$_,-1 ; 
    print join ( $sep , splice @F , ($c>0?0:$c) , abs $c ) , "\n" ; 
  }
}

sub packing {
  my $ind =  0 ;
  while ( <> ) { 
   $ind = shift @ca if $ind == 0 ;
   do { last if $o{1} ; @ca = @cols ; $ind = shift @ca } if ! defined $ind  ; 
   do { print "\n" ; redo } if $ind == 0 ;
   $ind -- ;
   chomp $_ ;
   print $_ ; 
   print $ind ? (eof () ) ? "\n" : $sep : "\n" ;  # () がつくことで@ARGV の各ファイルのEOFの検出では無くて、全部の最後を検出。
  }
}

## ヘルプとバージョン情報
BEGIN {
  $Getopt::Std::STANDARD_HELP_VERSION = 1 ; 
  our $VERSION = 0.00_14 ;
    # 最初は 0.21 を目安とする。
    # 1.00 以上とする必要条件は英語版のヘルプをきちんと出すこと。
    # 2.00 以上とする必要条件はテストコードが含むこと。
    # 0.00_12 : オプションを変えた。-rを使わず、-1を使うようにした。最後が改行で終了しないことがあることを抑制。
    # 0.00_13 : 列番号に0が指定された場合に対応。意味の無い指定に警告やエラーを出すようにした。
    # 0.00_14 : 区切り文字を変更できるようにした。
}  
sub HELP_MESSAGE {
    use FindBin qw[ $Script ] ; 
    $ARGV[1] //= '' ;
    open my $FH , '<' , $0 ;
    while(<$FH>){
        s/\$0/$Script/g ;
        print $_ if s/^=head1// .. s/^=cut// and $ARGV[1] =~ /^o(p(t(i(o(ns?)?)?)?)?)?$/i ? m/^\s+\-/ : 1;
    }
    close $FH ;
    exit 0 ;
}

=encoding utf8

=head1 

 $0 [-1] [-h] num1,num2,num3...,numk < somefile