tabdata/common.pl

   1 #!/usr/bin/env perl
   2
   3 $0 =~ s/^.*\/([^\/]+)$/$1/;
   4
   5 # Note: review escape_tabdata subroutine before you think about changing $FS and $RS fundamental variables.
   6 # Note: review "split $FS" calls if you ever change $FS to a single space char. "split ' '" is handled specially by Perl.
   7 $FS = "\t";
   8 $RS = $/ = "\n";
   9 @Header = ();
  10 %Header = ();
  11
  12 no if ($] >= 5.018), 'warnings' => 'experimental::smartmatch';
  13 use Getopt::Long qw/:config no_ignore_case bundling pass_through require_order no_getopt_compat no_auto_abbrev/;
  14 use Pod::Usage;
  15 use Encode;
  16
  17 binmode STDIN,  ':utf8';
  18 binmode STDOUT, ':utf8';
  19 @ARGV = map {Encode::_utf8_on($_); $_} @ARGV;
  20
  21
  22 if(not $TabdataCommonSkipGetopt)
  23 {
  24         GetOptions(
  25                 'help|?' => sub{ pod2usage(-exitval=>0, -verbose=>99); },
  26                 %OptionDefs,
  27         ) or pod2usage(-exitval=>2, -verbose=>99);
  28
  29         if('--' ~~ @ARGV and $ARGV[0] ne '--')
  30         {
  31                 # at least 1 unknown option remained in @ARGV
  32                 pod2usage(-exitval=>2, -verbose=>99, -msg=>"$0: unknown parameter: $ARGV[0]");
  33         }
  34
  35         # when pass_through option is set:
  36         # Note that the options terminator (default "--"), if present, will also be passed through in @ARGV.
  37         shift @ARGV if $ARGV[0] eq '--';
  38 }
  39
  40
  41 sub process_header
  42 {
  43         $HeaderLine = $_[0];
  44         chomp $HeaderLine;
  45         @Header = split $FS, $HeaderLine;
  46         %Header = ();
  47         for my $idx (0..$#Header)
  48         {
  49                 $Header{$Header[$idx]} = $idx;
  50         }
  51 }
  52
  53 sub sys_read_line
  54 {
  55         # read data from STDIN until $RS (usually newline) or EOF, whichever comes first.
  56         # and return with data.
  57         # $RS is consumed but not returned.
  58         # useful to avoid libc io-buffering in situations when the rest of STDIN will not be processed by the current process.
  59
  60         my $line = '';
  61         my $c;
  62         binmode STDIN, ':bytes';
  63         $line .= $c while sysread(STDIN, $c, 1) and $c ne $RS;
  64         binmode STDIN, ':utf8';
  65         return $line;
  66 }
  67
  68 sub read_record
  69 {
  70         my $fd = shift;
  71         my $line = <$fd>;
  72         chomp $line;
  73         my @record = split $FS, $line;
  74         return @record;
  75 }
  76
  77 sub escape_tabdata
  78 {
  79         my $arbitrary_data = shift;
  80         # Note, may be wrong if $FS or $RS are changed.
  81         my $tabdata = $arbitrary_data =~ s/[\t\n\r\e\\]/'\\'.{"\t"=>'t', "\n"=>'n', "\r"=>'r', "\e"=>'e', "\\"=>'\\'}->{$&}/ger;
  82         return $tabdata;
  83 }
  84
  85 sub unescape_tabdata
  86 {
  87         my $tabdata = shift;
  88         my $raw = $tabdata =~ s/\\[tnre\\]/eval "\"$&\""/ger;
  89         return $raw;
  90 }
  91
  92 sub kvpair_escape
  93 {
  94         my $s = shift;
  95         if($s =~ /[""'' ]/)
  96         {
  97                 $s =~ s/[\x00-\x1F\x7F""\\]/sprintf '\\x%02X', ord $&/eg;
  98                 $s = "\"$s\"";
  99         }
 100         return $s;
 101 }
 102
 103 sub kvpair_unescape
 104 {
 105         my $s = shift;
 106         if($s =~ /^(?'quote'[""''])(?'value'.*?)\g{quote}$/)
 107         {
 108                 $s = $+{'value'} =~ s/\\x([[:xdigit:]]{2})/chr hex $1/egir;
 109         }
 110         return $s;
 111 }
 112
 113 1;