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