tabdata/td-alter

   1 #!/usr/bin/env perl
   2
   3 =pod
   4
   5 =head1 NAME
   6
   7 td-alter - Add new columns and fields to tabular data stream, and modify value of existing fields.
   8
   9 =head1 USAGE
  10
  11 td-alter I<COLUMN>=I<EXPR> [I<COLUMN>=I<EXPR> [I<COLUMN>=I<EXPR> [...]]]
  12
  13 =head1 DESCRIPTION
  14
  15 On each data row, sets field in I<COLUMN> to the value resulted by I<EXPR>
  16 Perl expression.
  17
  18 In I<EXPR>, you may refer to other columns by C<$F{NAME}> where I<NAME> is the column name;
  19 or by C<$F[INDEX]> where I<INDEX> is the 0-based column index number;
  20 or in case of uppercase alpha-numeric field names, simply by bareword C<COLUMN>
  21 (because these are set up as subroutines internally).
  22 Topic variable (C<$_>) is set to the current value of I<COLUMN>.
  23
  24 You can create new columns simply by referring to a I<COLUMN> name that does not yet exist.
  25 You can refer to an earlier defined I<COLUMN> in subsequent I<EXPR> expressions.
  26
  27 =head1 EXAMPLES
  28
  29 Add new columns: TYPE and IS_BIGFILE.
  30 IS_BIGFILE depends on previously defined TYPE field.
  31
  32  ls -l | td-trans-ls | td-alter TYPE='substr MODE,0,1' IS_BIGFILE='SIZE>10000000 && TYPE ne "d" ? "yes" : "no"'
  33
  34 Strip sub-seconds and timezone from DATETIME field.
  35
  36  TIME_STYLE=full-iso ls -l | td-trans-ls | td-alter DATETIME='s/\..*//; $_'
  37
  38 =head1 OPTIONS
  39
  40 =over 4
  41
  42 =item -H, --no--header
  43
  44 do not show headers
  45
  46 =item -h, --header
  47
  48 show headers (default)
  49
  50 =back
  51
  52 =head1 REFERENCES
  53
  54 "Alter" in td-alter comes from SQL.
  55 td-alter(1) can change the "table" column layout.
  56 But contrary to SQL's ALTER TABLE, td-alter(1) can modify the records too, so akin to SQL UPDATE as well.
  57
  58 =cut
  59
  60 $OptShowHeader = 1;
  61 %OptionDefs = (
  62         'H|no-header' => sub { $OptShowHeader = 0; },
  63         'h|header' => sub { $OptShowHeader = 1; },
  64 );
  65
  66 no if ($] >= 5.018), 'warnings' => 'experimental::smartmatch';
  67 do '/usr/lib/tool/perl5/tabdata/common.pl' or die "$@";
  68
  69 process_header(scalar <STDIN>);
  70
  71 @Derives = ();
  72
  73 while(scalar @ARGV)
  74 {
  75         if($ARGV[0] =~ /^([^=]+)=(.*)/)
  76         {
  77                 my $column = $1;
  78                 my $expr = $2;
  79
  80                 if(not exists $Header{$column})
  81                 {
  82                         push @Header, $column;
  83                         $Header{$column} = $#Header;
  84                 }
  85
  86                 push @Derives, {'column'=>$column, 'expr'=>$expr};
  87         }
  88         else
  89         {
  90                 pod2usage(-exitval=>2, -verbose=>99, -msg=>"$0: unknown parameter: $ARGV[0]");
  91         }
  92         shift @ARGV;
  93 }
  94
  95 if($OptShowHeader and @Header)
  96 {
  97         print join($FS, @Header).$RS;
  98 }
  99
 100 while($line = <STDIN>)
 101 {
 102         chomp $line;
 103
 104         @F = split $FS, $line;
 105         %F = map {$_=>$F[$Header{$_}]} keys %Header;
 106
 107         for my $d (@Derives)
 108         {
 109                 my $cidx = $Header{$d->{'column'}};
 110                 my $expr_prerun = '';
 111                 for my $col (grep {/^[A-Z_][A-Z0-9_]*$/} @Header)
 112                 {
 113                         # define all (uppercase alpha-numeric only) column name as a subroutine
 114                         # which return the given field's value.
 115                         $expr_prerun .= sprintf('sub %s { $F{"%s"} };', $col, $col);
 116                 }
 117                 $expr_prerun .= '$_ = $F[$cidx];';
 118                 my $expr = $expr_prerun . $d->{'expr'};
 119
 120                 $F[$cidx] = $F{$d->{'column'}} = eval $expr;
 121                 warn $@ if $@;
 122         }
 123
 124         # undefined is empty string in tab-data format.
 125         for my $idx (0..$#F)
 126         {
 127                 $F[$idx] = '' if not defined $F[$idx];
 128         }
 129
 130         print join($FS, @F).$RS;
 131 }